6.8 Loading and Reloading Modules

You often need to reload modules in development and production environments. mod_perl tries hard to avoid unnecessary module reloading, but sometimes (especially during the development process) we want some modules to be reloaded when modified. The following sections discuss issues related to module loading and reloading.

6.8.1 The @INC Array Under mod_perl

Under mod_perl, @INC can be modified only during server startup. After each request, mod_perl resets @INC's value to the one it had before the request.

If mod_perl encounters a statement like the following:

use lib qw(foo/bar);

it modifies @INC only for the period during which the code is being parsed and compiled. Afterward, @INC is reset to its original value. Therefore, the only way to change @INC permanently is to modify it at server startup.

There are two ways to alter @INC at server startup:

• In the configuration file, with:

  PerlSetEnv PERL5LIB /home/httpd/perl

  or:

  PerlSetEnv PERL5LIB /home/httpd/perl:/home/httpd/mymodules

• In the startup.pl file:

  use lib qw(/home/httpd/perl /home/httpd/mymodules);
   1;

  As always, the startup file needs to be loaded from httpd.conf:

  PerlRequire /path/to/startup.pl

To make sure that you have set @INC correctly, configure perl-status into your server, as explained in Chapter 21. Follow the "Loaded Modules" item in the menu and look at the bottom of the generated page, where the contents of @INC are shown:

@INC = 
 /home/httpd/mymodules
 /home/httpd/perl
 /usr/lib/perl5/5.6.1/i386-linux
 /usr/lib/perl5/5.6.1
 /usr/lib/perl5/site_perl/5.6.1/i386-linux
 /usr/lib/perl5/site_perl/5.6.1
 /usr/lib/perl5/site_perl
 .
 /home/httpd/httpd_perl/
 /home/httpd/httpd_perl/lib/perl

As you can see in our setup, we have two custom directories prepended at the beginning of the list. The rest of the list contains standard directories from the Perl distribution, plus the $ServerRoot and $ServerRoot/lib/perl directories appended at the end (which mod_perl adds automatically).

6.8.2 Reloading Modules and Required Files

When working with mod_cgi, you can change the code and rerun the CGI script from your browser to see the changes. Since the script isn't cached in memory, the server starts up a new Perl interpreter for each request, which loads and recompiles the script from scratch. The effects of any changes are immediate.

The situation is different with mod_perl, since the whole idea is to get maximum performance from the server. By default, the server won't spend time checking whether any included library modules have been changed. It assumes that they weren't, thus saving the time it takes to stat( ) the source files from any modules and libraries you use( ) and require( ) in your script.

If the scripts are running under Apache::Registry, the only check that is performed is to see whether your main script has been changed. If your scripts do not use( ) or require( ) any other Perl modules or packages, there is nothing to worry about. If, however, you are developing a script that includes other modules, the files you use( ) or require( ) aren't checked for modification, and you need to do something about that.

There are a couple of techniques to make a mod_perl-enabled server recognize changes in library modules. They are discussed in the following sections.

6.8.2.1 Restarting the server

The simplest approach is to restart the server each time you apply some change to your code. Restarting techniques are covered in Chapter 5. After restarting the server about 50 times, you will tire of it and look for other solutions.

6.8.2.2 Using Apache::StatINC

Help comes from the Apache::StatINC module. When Perl pulls in a file with require( ), it stores the full pathname as a value in the global hash %INC with the filename as the key. Apache::StatINC looks through %INC and immediately reloads any file that has been updated on the disk.

To enable this module, add these two lines to httpd.conf:

PerlModule Apache::StatINC
 PerlInitHandler Apache::StatINC

To be sure it really works, turn on debug mode on your development system by adding PerlSetVar StatINCDebug On to your configuration file. You end up with something like this:

PerlModule Apache::StatINC
 PerlInitHandler Apache::StatINC
 <Location /perl>
     SetHandler perl-script
     PerlHandler Apache::Registry
     Options ExecCGI
     PerlSendHeader On
     PerlSetVar StatINCDebug On
 </Location>

Be aware that only the modules located in @INC are reloaded on change, and you can change @INC only before the server has been started (in the startup file).

Note the following trap: because ".", the current directory, is in @INC, Perl knows how to require( ) files with pathnames relative to the current script's directory. After the code has been parsed, however, the server doesn't remember the path. So if the code loads a module MyModule located in the directory of the script and this directory is not in @INC, you end up with the following entry in %INC:

'MyModule.pm' => 'MyModule.pm'

When Apache::StatINC tries to check whether the file has been modified, it won't be able to find the file, since MyModule.pm is not in any of the paths in @INC. To correct this problem, add the module's location path to @INC at server startup.

6.8.2.3 Using Apache::Reload

Apache::Reload is a newer module that comes as a drop-in replacement for Apache::StatINC. It provides extra functionality and is more flexible.

To make Apache::Reload check all the loaded modules on each request, just add the following line to httpd.conf:

PerlInitHandler Apache::Reload

To reload only specific modules when these get changed, three alternatives are provided: registering the module implicitly, registering the module explicitly, and setting up a dummy file to touch whenever you want the modules reloaded.

To use implicit module registration, turn off the ReloadAll variable, which is on by default:

PerlInitHandler Apache::Reload
 PerlSetVar ReloadAll Off

and add the following line to every module that you want to be reloaded on change:

use Apache::Reload;

Alternatively, you can explicitly specify modules to be reloaded in httpd.conf:

PerlInitHandler Apache::Reload
 PerlSetVar ReloadModules "Book::Foo Book::Bar Foo::Bar::Test"

Note that these are split on whitespace, but the module list must be in quotes, or Apache will try to parse the parameter list itself.

You can register groups of modules using the metacharacter *:

PerlSetVar ReloadModules "Foo::* Bar::*"

In the above example, all modules starting with Foo:: and Bar:: will become registered. This feature allows you to assign all the modules in a project using a single pattern.

The third option is to set up a file that you can touch to cause the reloads to be performed:

PerlSetVar ReloadTouchFile /tmp/reload_modules

Now when you're happy with your changes, simply go to the command line and type:

panic% touch /tmp/reload_modules

If you set this, and don't touch the file, the reloads won't happen (regardless of how the modules have been registered).

This feature is very convenient in a production server environment, but compared to a full restart, the benefits of preloaded modules memory-sharing are lost, since each child will get its own copy of the reloaded modules.

Note that Apache::Reload might have a problem with reloading single modules containing multiple packages that all use pseudo-hashes. The solution: don't use pseudo-hashes. Pseudo-hashes will be removed from newer versions of Perl anyway.

Just like with Apache::StatInc, if you have modules loaded from directories that are not in @INC, Apache::Reload will fail to find the files. This is because @INC is reset to its original value even if it gets temporarily modified in the script. The solution is to extend @INC at server startup to include all the directories from which you load files that aren't in the standard @INC paths.

6.8.2.4 Using dynamic configuration files

Sometimes you may want an application to monitor its own configuration file and reload it when it is altered. But you don't want to restart the server for these changes to take effect. The solution is to use dynamic configuration files.

Dynamic configuration files are especially useful when you want to provide administrators with a configuration tool that modifies an application on the fly. This approach eliminates the need to provide shell access to the server. It can also prevent typos, because the administration program can verify the submitted modifications.

It's possible to get away with Apache::Reload and still have a similar small overhead for the stat( ) call, but this requires the involvement of a person who can modify httpd.conf to configure Apache::Reload. The method described next has no such requirement.

6.8.2.4.1 Writing configuration files

We'll start by describing various approaches to writing configuration files, and their strengths and weaknesses.

If your configuration file contains only a few variables, it doesn't matter how you write the file. In practice, however, configuration files often grow as a project develops. This is especially true for projects that generate HTML files, since they tend to demand many easily configurable settings, such as the location of headers, footers, templates, colors, and so on.

A common approach used by CGI programmers is to define all configuration variables in a separate file. For example:

$cgi_dir  = '/home/httpd/perl';
 $cgi_url  = '/perl';
 $docs_dir = '/home/httpd/docs';
 $docs_url = '/';
 $img_dir  = '/home/httpd/docs/images';
 $img_url  = '/images';
 # ... many more config params here ...
 $color_hint   = '#777777';
 $color_warn   = '#990066';
 $color_normal = '#000000';

The use strict; pragma demands that all variables be declared. When using these variables in a mod_perl script, we must declare them with use vars in the script, so we start the script with:

use strict;
 use vars qw($cgi_dir $cgi_url $docs_dir $docs_url 
             # ... many more config params here ....
             $color_hint  $color_warn $color_normal
            );

It is a nightmare to maintain such a script, especially if not all features have been coded yetwe have to keep adding and removing variable names. Since we're writing clean code, we also start the configuration file with use strict;, so we have to list the variables with use vars here as wella second list of variables to maintain. Then, as we write many different scripts, we may get name collisions between configuration files.

The solution is to use the power of Perl's packages and assign a unique package name to each configuration file. For example, we might declare the following package name:

package Book::Config0;

Now each configuration file is isolated into its own namespace. But how does the script use these variables? We can no longer just require( ) the file and use the variables, since they now belong to a different package. Instead, we must modify all our scripts to use the configuration variables' fully qualified names (e.g., referring to $Book::Config0::cgi_url instead of just $cgi_url).

You may find typing fully qualified names tedious, or you may have a large repository of legacy scripts that would take a while to update. If so, you'll want to import the required variables into any script that is going to use them. First, the configuration package has to export those variables. This entails listing the names of all the variables in the @EXPORT_OK hash. See Example 6-21.

Example 6-21. Book/Config0.pm

package Book::Config0;
 use strict;
 
 BEGIN {
   use Exporter ( );
 
   @Book::HTML::ISA       = qw(Exporter);
   @Book::HTML::EXPORT    = qw( );
   @Book::HTML::EXPORT_OK = qw($cgi_dir $cgi_url $docs_dir $docs_url
                               # ... many more config params here ....
                               $color_hint $color_warn $color_normal);
 }
 
 use vars qw($cgi_dir $cgi_url $docs_dir $docs_url 
             # ... many more config params here ....
             $color_hint  $color_warn $color_normal
            );
 
 $cgi_dir  = '/home/httpd/perl';
 $cgi_url  = '/perl';
 $docs_dir = '/home/httpd/docs';
 $docs_url = '/';
 $img_dir  = '/home/httpd/docs/images';
 $img_url  = '/images';
 # ... many more config params here ...
 $color_hint   = "#777777';
 $color_warn   = "#990066';
 $color_normal = "#000000';

A script that uses this package will start with this code:

use strict;
 use Book::Config0 qw($cgi_dir $cgi_url $docs_dir $docs_url 
                      # ... many more config params here ....
                      $color_hint  $color_warn $color_normal
                   );
 use vars          qw($cgi_dir $cgi_url $docs_dir $docs_url 
                      # ... many more config params here ....
                      $color_hint  $color_warn $color_normal
                   );

Whoa! We now have to update at least three variable lists when we make a change in naming of the configuration variables. And we have only one script using the configuration file, whereas a real-life application often contains many different scripts.

There's also a performance drawback: exported variables add some memory overhead, and in the context of mod_perl this overhead is multiplied by the number of server processes running.

There are a number of techniques we can use to get rid of these problems. First, variables can be grouped in named groups called tags. The tags are later used as arguments to the import( ) or use( ) calls. You are probably familiar with:

use CGI qw(:standard :html);

We can implement this quite easily, with the help of export_ok_tags( ) from Exporter. For example:

BEGIN {
   use Exporter ( );
   use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
   @ISA         = qw(Exporter);
   @EXPORT      = ( );
   @EXPORT_OK   = ( );
 
   %EXPORT_TAGS = (
       vars => [qw($firstname $surname)],
       subs => [qw(reread_conf untaint_path)],
   );
   Exporter::export_ok_tags('vars');
   Exporter::export_ok_tags('subs');
 }

In the script using this configuration, we write:

use Book::Config0 qw(:subs :vars);

Subroutines are exported exactly like variables, since symbols are what are actually being exported. Notice we don't use export_tags( ), as it exports the variables automatically without the user asking for them (this is considered bad style). If a module automatically exports variables with export_tags( ), you can avoid unnecessary imports in your script by using this syntax:

use Book::Config0 ( );

You can also go even further and group tags into other named groups. For example, the :all tag from CGI.pm is a group tag of all other groups. It requires a little more effort to implement, but you can always save time by looking at the solution in CGI.pm's code. It's just a matter of an extra code to expand all the groups recursively.

As the number of variables grows, however, your configuration will become unwieldy. Consider keeping all the variables in a single hash built from references to other scalars, anonymous arrays, and hashes. See Example 6-22.

Example 6-22. Book/Config1.pm

package Book::Config1;
 use strict;
 
 BEGIN {
   use Exporter ( );
 
   @Book::Config1::ISA       = qw(Exporter);
   @Book::Config1::EXPORT    = qw( );
   @Book::Config1::EXPORT_OK = qw(%c);
 }
 
 use vars qw(%c);
 
 %c = (
    dir => {
        cgi  => '/home/httpd/perl',
        docs => '/home/httpd/docs',
        img  => '/home/httpd/docs/images',
       },
    url => {
        cgi  => '/perl',
        docs => '/',
        img  => '/images',
       },
    color => {
          hint   => '#777777',
          warn   => '#990066',
          normal => '#000000',
         },
   );

Good Perl style suggests keeping a comma at the end of each list. This makes it easy to add new items at the end of a list.

Our script now looks like this:

use strict;
 use Book::Config1 qw(%c);
 use vars          qw(%c);
 print "Content-type: text/plain\n\n";
 print "My url docs root: $c{url}{docs}\n";

The whole mess is gone. Now there is only one variable to worry about.

The one small downside to this approach is auto-vivification. For example, if we write $c{url}{doc} by mistake, Perl will silently create this element for us with the value undef. When we use strict;, Perl will tell us about any misspelling of this kind for a simple scalar, but this check is not performed for hash elements. This puts the onus of responsibility back on us, since we must take greater care.

The benefits of the hash approach are significant. Let's make it even better by getting rid of the Exporter stuff completely, removing all the exporting code from the configuration file. See Example 6-23.

Example 6-23. Book/Config2.pm

package Book::Config2;
 use strict;
 use vars qw(%c);
 
 %c = (
    dir => {
        cgi  => '/home/httpd/perl',
        docs => '/home/httpd/docs',
        img  => '/home/httpd/docs/images',
       },
    url => {
        cgi  => '/perl',
        docs => '/',
        img  => '/images',
       },
    color => {
          hint   => '#777777',
          warn   => '#990066',
          normal => '#000000',
         },
   );

Our script is modified to use fully qualified names for the configuration variables it uses:

use strict;
 use Book::Config2 ( );
 print "Content-type: text/plain\n\n";
 print "My url docs root: $Book::Config2::c{url}{docs}\n";

To save typing and spare the need to use fully qualified variable names, we'll use a magical Perl feature to alias the configuration variable to a script's variable:

use strict;
 use Book::Config2 ( );
 use vars qw(%c);
 *c = \%Book::Config2::c;
 print "Content-type: text/plain\n\n";
 print "My url docs root: $c{url}{docs}\n";

We've aliased the *c glob with a reference to the configuration hash. From now on, %Book::Config2::c and %c refer to the same hash for all practical purposes.

One last point: often, redundancy is introduced in configuration variables. Consider:

$cgi_dir  = '/home/httpd/perl';
 $docs_dir = '/home/httpd/docs';
 $img_dir  = '/home/httpd/docs/images';

It's obvious that the base path /home/httpd should be moved to a separate variable, so only that variable needs to be changed if the application is moved to another location on the filesystem.

$base     = '/home/httpd';
 $cgi_dir  = "$base/perl";
 $docs_dir = "$base/docs";
 $img_dir  = "$docs_dir/images";

This cannot be done with a hash, since we cannot refer to its values before the definition is completed. That is, this will not work:

%c = (
    base => '/home/httpd',
    dir => {
        cgi  => "$c{base}/perl",
        docs => "$c{base}/docs",
        img  => "$c{base}{docs}/images",
       },
   );

But nothing stops us from adding additional variables that are lexically scoped with my( ). The following code is correct:

my $base = '/home/httpd';
 %c = (
    dir => {
        cgi  => "$base/perl",
        docs => "$base/docs",
        img  => "$base/docs/images",
       },
   );

We've learned how to write configuration files that are easy to maintain, and how to save memory by avoiding importing variables in each script's namespace. Now let's look at reloading those files.

6.8.2.4.2 Reloading configuration files

First, lets look at a simple case, in which we just have to look after a simple configuration file like the one below. Imagine a script that tells you who is the patch pumpkin of the current Perl release.^[2] (Pumpkin is a whimsical term for the person with exclusive access to a virtual "token" representing a certain authority, such as applying patches to a master copy of some source.)

^[2] These are the recent pumpkins: Chip Salzenberg for 5.004, Gurusamy Sarathy for 5.005 and 5.6, Jarkko Hietaniemi for 5.8, Hugo van der Sanden for 5.10.

use CGI ( );
 use strict;
 
 my $firstname = "Jarkko";
 my $surname = "Hietaniemi";
 my $q = CGI->new;
 
 print $q->header(-type=>'text/html');
 print $q->p("$firstname $surname holds the patch pumpkin" .
              "for this Perl release.");

The script is very simple: it initializes the CGI object, prints the proper HTTP header, and tells the world who the current patch pumpkin is. The name of the patch pumpkin is a hardcoded value.

We don't want to modify the script every time the patch pumpkin changes, so we put the $firstname and $surname variables into a configuration file:

$firstname = "Jarkko";
 $surname = "Hietaniemi";
 1;

Note that there is no package declaration in the above file, so the code will be evaluated in the caller's package or in the main:: package if none was declared. This means that the variables $firstname and $surname will override (or initialize) the variables with the same names in the caller's namespace. This works for global variables onlyyou cannot update variables defined lexically (with my( )) using this technique.

Let's say we have started the server and everything is working properly. After a while, we decide to modify the configuration. How do we let our running server know that the configuration was modified without restarting it? Remember, we are in production, and a server restart can be quite expensive. One of the simplest solutions is to poll the file's modification time by calling stat( ) before the script starts to do real work. If we see that the file was updated, we can force a reconfiguration of the variables located in this file. We will call the function that reloads the configuration reread_conf( ) and have it accept the relative path to the configuration file as its single argument.

Apache::Registry executes a chdir( ) to the script's directory before it starts the script's execution. So if your CGI script is invoked under the Apache::Registry handler, you can put the configuration file in the same directory as the script. Alternatively, you can put the file in a directory below that and use a path relative to the script directory. However, you have to make sure that the file will be found, somehow. Be aware that do( ) searches the libraries in the directories in @INC.

use vars qw(%MODIFIED);
 sub reread_conf {
     my $file = shift;
     return unless defined $file;
     return unless -e $file and -r _;
     my $mod = -M _;
     unless (exists $MODIFIED{$file} and $MODIFIED{$file} =  = $mod) {
         unless (my $result = do $file) {
             warn "couldn't parse $file: $@" if $@;
             warn "couldn't read $file: $!" unless defined $result;
             warn "couldn't run $file"      unless         $result;
         }
         $MODIFIED{$file} = $mod; # Update the MODIFICATION times
     }
 }

Notice that we use the = = comparison operator when checking the file's modification timestamp, because all we want to know is whether the file was changed or not.

When the require( ), use( ), and do( ) operators successfully return, the file that was passed as an argument is inserted into %INC. The hash element key is the name of the file, and the element's value is the file's path. When Perl sees require( ) or use( ) in the code, it first tests %INC to see whether the file is already there and thus loaded. If the test returns true, Perl saves the overhead of code rereading and recompiling; however, calling do( ) will load or reload the file regardless of whether it has been previously loaded.

We use do( ), not require( ), to reload the code in this file because although do( ) behaves almost identically to require( ), it reloads the file unconditionally. If do( ) cannot read the file, it returns undef and sets $! to report the error. If do( ) can read the file but cannot compile it, it returns undef and sets an error message in $@. If the file is successfully compiled, do( ) returns the value of the last expression evaluated.

The configuration file can be broken if someone has incorrectly modified it. Since we don't want the whole service using that file to be broken that easily, we trap the possible failure to do( ) the file and ignore the changes by resetting the modification time. If do( ) fails to load the file, it might be a good idea to send an email about the problem to the system administrator.

However, since do( ) updates %INC like require( ) does, if you are using Apache::StatINC it will attempt to reload this file before the reread_conf( ) call. If the file doesn't compile, the request will be aborted. Apache::StatINC shouldn't be used in production anyway (because it slows things down by stat( )ing all the files listed in %INC), so this shouldn't be a problem.

Note that we assume that the entire purpose of this function is to reload the configuration if it was changed. This is fail-safe, because if something goes wrong we just return without modifying the server configuration. The script should not be used to initialize the variables on its first invocation. To do that, you would need to replace each occurrence of return( ) and warn( ) with die( ).

We've used the above approach with a huge configuration file that was loaded only at server startup and another little configuration file that included only a few variables that could be updated by hand or through the web interface. Those variables were initialized in the main configuration file. If the webmaster breaks the syntax of this dynamic file while updating it by hand, it won't affect the main (write-protected) configuration file and won't stop the proper execution of the programs. In the next section, we will see a simple web interface that allows us to modify the configuration file without the risk of breaking it.

Example 6-24 shows a sample script using our reread_conf( ) subroutine.

Example 6-24. reread_conf.pl

use vars qw(%MODIFIED $firstname $surname);
 use CGI ( );
 use strict;
 
 my $q = CGI->new;
 print $q->header(-type => 'text/plain');
 my $config_file = "./config.pl";
 reread_conf($config_file);
 print $q->p("$firstname $surname holds the patch pumpkin" .
              "for this Perl release.");
 
 sub reread_conf {
     my $file = shift;
     return unless defined $file;
     return unless -e $file and -r _;
     my $mod = -M _;
     unless ($MODIFIED{$file} and $MODIFIED{$file} == $mod) {
         unless (my $result = do $file) {
             warn "couldn't parse $file: $@" if $@;
             warn "couldn't read $file: $!"  unless defined $result;
             warn "couldn't run $file"       unless $result;
         }
         $MODIFIED{$file} = $mod; # Update the MODIFICATION time
     }
 }

You should be using (stat $file)[9] instead of -M $file if you are modifying the $^T variable. This is because -M returns the modification time relative to the Perl interpreter startup time, set in $^T. In some scripts, it can be useful to reset $^T to the time of the script invocation with "local $^T = time( )". That way, -M and other -X file status tests are performed relative to the script invocation time, not the time the process was started.

If your configuration file is more sophisticatedfor example, if it declares a package and exports variablesthe above code will work just as well. Variables need not be import( )ed again: when do( ) recompiles the script, the originally imported variables will be updated with the values from the reloaded code.

6.8.2.4.3 Dynamically updating configuration files

The CGI script below allows a system administrator to dynamically update a configuration file through a web interface. This script, combined with the code we have just seen to reload the modified files, gives us a system that is dynamically reconfigurable without having to restart the server. Configuration can be performed from any machine that has a browser.

Let's say we have a configuration file like the one in Example 6-25.

Example 6-25. Book/MainConfig.pm

package Book::MainConfig;
 
 use strict;
 use vars qw(%c);
 
 %c = (
       name     => "Larry Wall",
       release  => "5.000",
       comments => "Adding more ways to do the same thing :)",
 
       other    => "More config values",
 
       colors   => { foreground => "black",
                     background => "white",
                   },
 
       machines => [qw( primary secondary tertiary )],
 
 );

We want to make the variables name, release, and comments dynamically configurable. We'll need a web interface with an input form that allows modifications to these variables. We'll also need to update the configuration file and propagate the changes to all the currently running processes.

Let's look at the main stages of the implementation:

The only part that seems hard to implement is a configuration file update, for a couple of reasons. If updating the file breaks it, the whole service won't work. If the file is very big and includes comments and complex data structures, parsing the file can be quite a challenge.

So let's simplify the task. If all we want is to update a few variables, why don't we create a tiny configuration file containing just those variables? It can be modified through the web interface and overwritten each time there is something to be changed, so that we don't have to parse the file before updating it. If the main configuration file is changed, we don't care, because we don't depend on it any more.

The dynamically updated variables will be duplicated in the main file and the dynamic file. We do this to simplify maintenance. When a new release is installed, the dynamic configuration file won't existit will be created only after the first update. As we just saw, the only change in the main code is to add a snippet to load this file if it exists and was changed.

This additional code must be executed after the main configuration file has been loaded. That way, the updated variables will override the default values in the main file. See Example 6-26.

Example 6-26. manage_conf.pl

# remember to run this code in taint mode
 use strict;
 use vars qw($q %c $dynamic_config_file %vars_to_change %validation_rules);
 
 use CGI ( );
 
 use lib qw(.);
 use Book::MainConfig ( );
 *c = \%Book::MainConfig::c;
 
 $dynamic_config_file = "./config.pl";
 
 # load the dynamic configuration file if it exists, and override the
 # default values from the main configuration file
 do $dynamic_config_file if -e $dynamic_config_file and -r _;
 
 # fields that can be changed and their captions
 %vars_to_change =
   (
    'name'     => "Patch Pumpkin's Name",
    'release'  => "Current Perl Release",
    'comments' => "Release Comments",
   );
 
 # each field has an associated regular expression
 # used to validate the field's content when the
 # form is submitted
 %validation_rules =
   (
    'name'     => sub { $_[0] =~ /^[\w\s\.]+$/;   },
    'release'  => sub { $_[0] =~ /^\d+\.[\d_]+$/; },
    'comments' => sub { 1;                        },
   );
 
 # create the CGI object, and print the HTTP and HTML headers
 $q = CGI->new;
 print $q->header(-type=>'text/html'), 
       $q->start_html( );
 
 # We always rewrite the dynamic config file, so we want all the
 # variables to be passed, but to save time we will only check
 # those variables that were changed.  The rest will be retrieved from
 # the 'prev_*' values.
 my %updates = ( );
 foreach (keys %vars_to_change) {
     # copy var so we can modify it
     my $new_val = $q->param($_) || '';
 
     # strip a possible ^M char (Win32)
     $new_val =~ s/\cM//g;
 
     # push to hash if it was changed
     $updates{$_} = $new_val
         if defined $q->param("prev_" . $_)
            and $new_val ne $q->param("prev_" . $_);
 }
 
 # Note that we cannot trust the previous values of the variables
 # since they were presented to the user as hidden form variables,
 # and the user could have mangled them. We don't care: this can't do
 # any damage, as we verify each variable by rules that we define.
 
 # Process if there is something to process. Will not be called if
 # it's invoked the first time to display the form or when the form
 # was submitted but the values weren't modified (we'll know by
 # comparing with the previous values of the variables, which are
 # the hidden fields in the form).
 
 process_changed_config(%updates) if %updates;
 
 show_modification_form( );
  
 # update the config file, but first validate that the values are
 # acceptable
 sub process_changed_config {
     my %updates = @_;
 
     # we will list here all variables that don't validate
     my %malformed = ( );
 
     print $q->b("Trying to validate these values<br>");
     foreach (keys %updates) {
         print "<dt><b>$_</b> => <pre>$updates{$_}</pre>";
 
         # now we have to handle each var to be changed very carefully,
         # since this file goes immediately into production!
         $malformed{$_} = delete $updates{$_}
             unless $validation_rules{$_}->($updates{$_});
 
     }   
 
     if (%malformed) {
         print $q->hr,
             $q->p($q->b(qq{Warning! These variables were changed
                            to invalid values. The original
                            values will be kept.})
                  ),
             join ",<br>",
                  map { $q->b($vars_to_change{$_}) . " : $malformed{$_}\n"
                      } keys %malformed;
     }
 
     # Now complete the vars that weren't changed from the
     # $q->param('prev_var') values
     map { $updates{$_} = $q->param('prev_' . $_)
               unless exists $updates{$_} } keys %vars_to_change;
 
     # Now we have all the data that should be written into the dynamic
     # config file
 
     # escape single quotes "'" while creating a file
     my $content = join "\n",
         map { $updates{$_} =~ s/(['\\])/\\$1/g;
               '$c{' . $_ . "} = '" . $updates{$_} . "';\n"
             } keys %updates;
 
     # add '1;' to make require( ) happy
     $content .= "\n1;";
 
     # keep the dummy result in $res so it won't complain
     eval {my $res = $content};
     if ($@) {
         print qq{Warning! Something went wrong with config file
                  generation!<p> The error was :</p> <br><pre>$@</pre>};
         return;
     }
 
     print $q->hr;
 
     # overwrite the dynamic config file
     my $fh = Apache::gensym( );
     open $fh, ">$dynamic_config_file.bak"
         or die "Can't open $dynamic_config_file.bak for writing: $!";
     flock $fh, 2; # exclusive lock
     seek $fh, 0, 0; # rewind to the start
     truncate $fh, 0; # the file might shrink!
     print $fh $content;
     close $fh;
 
     # OK, now we make a real file
     rename "$dynamic_config_file.bak", $dynamic_config_file
         or die "Failed to rename: $!";
 
     # rerun it to update variables in the current process! Note that
     # it won't update the variables in other processes. Special
     # code that watches the timestamps on the config file will do this
     # work for each process. Since the next invocation will update the
     # configuration anyway, why do we need to load it here? The reason
     # is simple: we are going to fill the form's input fields with
     # the updated data.
     do $dynamic_config_file;
 
 }
 
 sub show_modification_form {
 
     print $q->center($q->h3("Update Form"));
   
     print $q->hr,
         $q->p(qq{This form allows you to dynamically update the current
            configuration. You don't need to restart the server in
            order for changes to take an effect}
              );
   
     # set the previous settings in the form's hidden fields, so we
     # know whether we have to do some changes or not
     $q->param("prev_$_", $c{$_}) for keys %vars_to_change;
   
     # rows for the table, go into the form
     my @configs = ( );
   
     # prepare text field entries
     push @configs,
         map {
           $q->td( $q->b("$vars_to_change{$_}:") ),
           $q->td(
            $q->textfield(
                  -name      => $_,
                  -default   => $c{$_},
                  -override  => 1,
                  -size      => 20,
                  -maxlength => 50,
                 )
           ),
         } qw(name release);
   
     # prepare multiline textarea entries
     push @configs,
         map {
           $q->td( $q->b("$vars_to_change{$_}:") ),
           $q->td(
            $q->textarea(
                 -name     => $_,
                 -default  => $c{$_},
                 -override => 1,
                 -rows     => 10,
                 -columns  => 50,
                 -wrap     => "HARD",
                 )
           ),
         } qw(comments);
   
     print $q->startform(POST => $q->url), "\n",
           $q->center(
               $q->table(map {$q->Tr($_), "\n",} @configs),
               $q->submit('', 'Update!'), "\n",
           ),
           map ({$q->hidden("prev_" . $_, $q->param("prev_".$_)) . "\n" }
                keys %vars_to_change), # hidden previous values
           $q->br, "\n",
           $q->endform, "\n",
           $q->hr, "\n",
           $q->end_html;
   
 }

For example, on July 19 2002, Perl 5.8.0 was released. On that date, Jarkko Hietaniemi exclaimed:

The pumpking is dead! Long live the pumpking!

Hugo van der Sanden is the new pumpking for Perl 5.10. Therefore, we run manage_conf.pl and update the data. Once updated, the script overwrites the previous config.pl file with the following content:

$c{release}  =  '5.10';
 
 $c{name}  =  'Hugo van der Sanden';
 
 $c{comments}  =  'Perl rules the world!';
 
 1;

Instead of crafting your own code, you can use the CGI::QuickForm module from CPAN to make the coding less tedious. See Example 6-27.

Example 6-27. manage_conf.pl

use strict;
 use CGI qw( :standard :html3 ) ;
 use CGI::QuickForm;
 use lib qw(.);
 use Book::MainConfig ( );
 *c = \%Book::MainConfig::c;
 
 my $TITLE = 'Update Configuration';
 show_form(
     -HEADER => header . start_html( $TITLE ) . h3( $TITLE ),
     -ACCEPT => \&on_valid_form,
     -FIELDS => [
         {
             -LABEL      => "Patch Pumpkin's Name",
             -VALIDATE   => sub { $_[0] =~ /^[\w\s\.]+$/;   },
             -default    => $c{name},
         },
         {
             -LABEL      => "Current Perl Release",
             -VALIDATE   => sub { $_[0] =~ /^\d+\.[\d_]+$/; },
             -default    => $c{release},
         },
         {
             -LABEL      => "Release Comments",
             -default    => $c{comments},
         },
         ],
     );
 
 sub on_valid_form {
     # save the form's values
 }

That's it. show_form( ) creates and displays a form with a submit button. When the user submits, the values are checked. If all the fields are valid, on_valid_form( ) is called; otherwise, the form is re-presented with the errors highlighted.

6.9 Handling the "User Pressed Stop Button" Case When a user presses the Stop or Reload button, the current socket connection is broken (aborted). It would be nice if Apache could always immediately detect this event. Unfortunately, there is no way to tell whether the connection is still valid unless an attempt to read from or write to the connection is made. Note that no detection technique will work if the connection to the backend mod_perl server is coming from a frontend mod_proxy (as discussed in Chapter 12). This is because mod_proxy doesn't break the connection to the backend when the user has aborted the connection. If the reading of the request's data is completed and the code does its processing without writing anything back to the client, the broken connection won't be noticed. When an attempt is made to send at least one character to the client, the broken connection will be noticed and the SIGPIPE signal (Broken Pipe) will be sent to the process. The program can then halt its execution and perform all its cleanup requirements. Prior to Apache 1.3.6, SIGPIPE was handled by Apache. Currently, Apache does not handle SIGPIPE, but mod_perl takes care of it. Under mod_perl, $r->print (or just print( )) returns a true value on success and a false value on failure. The latter usually happens when the connection is broken. If you want behavior similar to the old SIGPIPE (as it was before Apache version 1.3.6), add the following configuration directive: PerlFixupHandler Apache::SIG When Apache's SIGPIPE handler is used, Perl may be left in the middle of its eval( ) context, causing bizarre errors when subsequent requests are handled by that child. When Apache::SIG is used, it installs a different SIGPIPE handler that rewinds the context to make sure Perl is in a normal state before the new request is served, preventing these bizarre errors. But in general, you don't need to use Apache::SIG. If you use Apache::SIG and you would like to log when a request was canceled by a SIGPIPE in your Apache access_log, you must define a custom LogFormat in your httpd.conf. For example: PerlFixupHandler Apache::SIG LogFormat "%h %l %u %t \"%r\" %s %b %{SIGPIPE}e" If the server has noticed that the request was canceled via a SIGPIPE, the log line will end with 1. Otherwise, it will just be a dash. For example: 127.0.0.1 - - [09/Jan/2001:10:27:15 +0100] "GET /perl/stopping_detector.pl HTTP/1.0" 200 16 1 127.0.0.1 - - [09/Jan/2001:10:28:18 +0100] "GET /perl/test.pl HTTP/1.0" 200 10 - 6.9.1 Detecting Aborted Connections Now let's use the knowledge we have acquired to trace the execution of the code and watch all the events as they happen. Let's take a simple Apache::Registry script that purposely hangs the server process, like the one in Example 6-28. Example 6-28. stopping_detector.pl my $r = shift; $r->send_http_header('text/plain'); print "PID = $$\n"; $r->rflush; while (1) { sleep 1; } The script gets a request object $r by shift( )ing it from the @_ argument list (passed by the handler( ) subroutine that was created on the fly by Apache::Registry). Then the script sends a Content-Type header telling the client that we are going to send a plain-text response. Next, the script prints out a single line telling us the ID of the process that handled the request, which we need to know in order to run the tracing utility. Then we flush Apache's STDOUT buffer. If we don't flush the buffer, we will never see this information printed (our output is shorter than the buffer size used for print( ), and the script intentionally hangs, so the buffer won't be auto-flushed).[3] [3] Buffering is used to reduce the number of system calls (which do the actual writing) and therefore improve performance. When the buffer (usually a few kilobytes in size) is getting full, it's flushed and the data is written. Then we enter an infinite while loop that does nothing but sleep( ), emulating code that doesn't generate any output. For example, it might be a long-running mathematical calculation, a database query, or a search for extraterrestrial life. Running strace -p PID, where PID is the process ID as printed on the browser, we see the following output printed every second: rt_sigprocmask(SIG_BLOCK, [CHLD], [ ], 8) = 0 rt_sigaction(SIGCHLD, NULL, {SIG_DFL}, 8) = 0 rt_sigprocmask(SIG_SETMASK, [ ], NULL, 8) = 0 nanosleep({1, 0}, {1, 0}) = 0 time([978969822]) = 978969822 time([978969822]) = 978969822 Alternatively, we can run the server in single-server mode. In single-server mode, we don't need to print the process ID, since the PID is the process of the single mod_perl process that we're running. When the process is started in the background, the shell program usually prints the PID of the process, as shown here: panic% httpd -X & [1] 20107 Now we know what process we have to attach to with strace (or a similar utility): panic% strace -p 20107 rt_sigprocmask(SIG_BLOCK, [CHLD], [ ], 8) = 0 rt_sigaction(SIGCHLD, NULL, {SIG_DFL}, 8) = 0 rt_sigprocmask(SIG_SETMASK, [ ], NULL, 8) = 0 nanosleep({1, 0}, {1, 0}) = 0 time([978969822]) = 978969822 time([978969822]) = 978969822 We see the same output as before. Let's leave strace running and press the Stop button. Did anything change? No, the same system calls trace is printed every second, which means that Apache didn't detect the broken connection. Now we are going to write \0 (NULL) characters to the client in an attempt to detect the broken connection as soon as possible after the Stop button is pressed. Since these are NULL characters, they won't be seen in the output. Therefore, we modify the loop code in the following way: while (1) { $r->print("\0"); last if $r->connection->aborted; sleep 1; } We add a print( ) statement to print a NULL character, then we check whether the connection was aborted, with the help of the $r->connection->aborted method. If the connection is broken, we break out of the loop. We run this script and run strace on it as before, but we see that it still doesn't workthe script doesn't stop when the Stop button is pressed. The problem is that we aren't flushing the buffer. The NULL characters won't be printed until the buffer is full and is autoflushed. Since we want to try writing to the connection pipe all the time, we add an $r->rflush( ) call. Example 6-29 is a new version of the code. Example 6-29. stopping_detector2.pl my $r = shift; $r->send_http_header('text/plain'); print "PID = $$\n"; $r->rflush; while (1) { $r->print("\0"); $r->rflush; last if $r->connection->aborted; sleep 1; } After starting the strace utility on the running process and pressing the Stop button, we see the following output: rt_sigprocmask(SIG_BLOCK, [CHLD], [ ], 8) = 0 rt_sigaction(SIGCHLD, NULL, {SIG_DFL}, 8) = 0 rt_sigprocmask(SIG_SETMASK, [ ], NULL, 8) = 0 nanosleep({1, 0}, {1, 0}) = 0 time([978970895]) = 978970895 alarm(300) = 0 alarm(0) = 300 write(3, "\0", 1) = -1 EPIPE (Broken pipe) --- SIGPIPE (Broken pipe) --- chdir("/usr/src/httpd_perl") = 0 select(4, [3], NULL, NULL, {0, 0}) = 1 (in [3], left {0, 0}) time(NULL) = 978970895 write(17, "127.0.0.1 - - [08/Jan/2001:19:21"..., 92) = 92 gettimeofday({978970895, 554755}, NULL) = 0 times({tms_utime=46, tms_stime=5, tms_cutime=0, tms_cstime=0}) = 8425400 close(3) = 0 rt_sigaction(SIGUSR1, {0x8099524, [ ], SA_INTERRUPT|0x4000000}, {SIG_IGN}, 8) = 0alarm(0) = 0 rt_sigprocmask(SIG_BLOCK, NULL, [ ], 8) = 0 rt_sigaction(SIGALRM, {0x8098168, [ ], SA_RESTART|0x4000000}, {0x8098168, [ ], SA_INTERRUPT|0x4000000}, 8) = 0 fcntl(18, F_SETLKW, {type=F_WRLCK, whence=SEEK_SET, start=0, len=0}) = 0 Apache detects the broken pipe, as you can see from this snippet: write(3, "\0", 1) = -1 EPIPE (Broken pipe) --- SIGPIPE (Broken pipe) --- Then it stops the script and does all the cleanup work, such as access logging: write(17, "127.0.0.1 - - [08/Jan/2001:19:21"..., 92) = 92 where 17 is a file descriptor of the opened access_log file. 6.9.2 The Importance of Cleanup Code Cleanup code is a critical issue with aborted scripts. For example, what happens to locked resources, if there are any? Will they be freed or not? If not, scripts using these resources and the same locking scheme might hang forever, waiting for these resources to be freed. And what happens if a file was opened and never closed? In some cases, this might lead to a file-descriptor leakage. In the long run, many leaks of this kind might make your system unusable: when all file descriptors are used, the system will be unable to open new files. First, let's take a step back and recall what the problems and solutions for these issues are under mod_cgi. Under mod_cgi, the resource-locking issue is a problem only if you use external lock files and use them for lock indication, instead of using flock( ). If the script running under mod_cgi is aborted between the lock and the unlock code, and you didn't bother to write cleanup code to remove old, dead locks, you're in big trouble. The solution is to place the cleanup code in an END block: END { # code that ensures that locks are removed } When the script is aborted, Perl will run the END block while shutting down. If you use flock( ), things are much simpler, since all opened files will be closed when the script exits. When the file is closed, the lock is removed as wellall the locked resources are freed. There are systems where flock( ) is unavailable; on those systems, you can use Perl's emulation of this function. With mod_perl, things can be more complex when you use global variables as filehandles. Because processes don't exit after processing a request, files won't be closed unless you explicitly close( ) them or reopen them with the open( ) call, which first closes the file. Let's see what problems we might encounter and look at some possible solutions. 6.9.2.1 Critical section First, we want to take a little detour to discuss the "critical section" issue. Let's start with a resource-locking scheme. A schematic representation of a proper locking technique is as follows: Lock a resource <critical section starts> Do something with the resource <critical section ends> Unlock the resource If the locking is exclusive, only one process can hold the resource at any given time, which means that all the other processes will have to wait. The code between the locking and unlocking functions cannot be interrupted and can therefore become a service bottleneck. That's why this code section is called critical. Its execution time should be as short as possible. Even if you use a shared locking scheme, in which many processes are allowed to concurrently access the resource, it's still important to keep the critical section as short as possible, in case a process requires an exclusive lock. Example 6-30 uses a shared lock but has a poorly designed critical section. Example 6-30. critical_section_sh.pl use Fcntl qw(:flock); use Symbol; my $fh = gensym; open $fh, "/tmp/foo" or die $!; # start critical section flock $fh, LOCK_SH; # shared lock, appropriate for reading seek $fh, 0, 0; my @lines = <$fh>; for (@lines) { print if /foo/; } close $fh; # close unlocks the file # end critical section The code opens the file for reading, locks and rewinds it to the beginning, reads all the lines from the file, and prints out the lines that contain the string "foo". The gensym( ) function imported by the Symbol module creates an anonymous glob data structure and returns a reference to it. Such a glob reference can be used as a file or directory handle. Therefore, it allows lexically scoped variables to be used as filehandles. Fcntl imports file-locking symbols, such as LOCK_SH, LOCK_EX, and others with the :flock group tag, into the script's namespace. Refer to the Fcntl manpage for more information about these symbols. If the file being read is big, it will take a relatively long time for this code to complete printing out the lines. During this time, the file remains open and locked with a shared lock. While other processes may access this file for reading, any process that wants to modify the file (which requires an exclusive lock) will be blocked waiting for this section to complete. We can optimize the critical section as follows. Once the file has been read, we have all the information we need from it. To make the example simpler, we've chosen to just print out the matching lines. In reality, the code might be much longer. We don't need the file to be open while the loop executes, because we don't access it inside the loop. Closing the file before we start the loop will allow other processes to obtain exclusive access to the file if they need it, instead of being blocked for no reason. Example 6-31 is an improved version of the previous example, in which we only read the contents of the file during the critical section and process it afterward, without creating a possible bottleneck. Example 6-31. critical_section_sh2.pl use Fcntl qw(:flock); use Symbol; my $fh = gensym; open $fh, "/tmp/foo" or die $!; # start critical section flock $fh, LOCK_SH; seek $fh, 0, 0; my @lines = <$fh>; close $fh; # close unlocks the file # end critical section for (@lines) { print if /foo/; } Example 6-32 is a similar example that uses an exclusive lock. The script reads in a file and writes it back, prepending a number of new text lines to the head of the file. Example 6-32. critical_section_ex.pl use Fcntl qw(:flock); use Symbol; my $fh = gensym; open $fh, "+>>/tmp/foo" or die $!; # start critical section flock $fh, LOCK_EX; seek $fh, 0, 0; my @add_lines = ( qq{Complete documentation for Perl, including FAQ lists,\n}, qq{should be found on this system using 'man perl' or\n}, qq{'perldoc perl'. If you have access to the Internet, point\n}, qq{your browser at http://www.perl.com/, the Perl Home Page.\n}, ); my @lines = (@add_lines, <$fh>); seek $fh, 0, 0; truncate $fh, 0; print $fh @lines; close $fh; # close unlocks the file # end critical section Since we want to read the file, modify it, and write it back without anyone else changing it in between, we open it for reading and writing with the help of "+>>" and lock it with an exclusive lock. You cannot safely accomplish this task by opening the file first for reading and then reopening it for writing, since another process might change the file between the two events. (You could get away with "+<" as well; please refer to the perlfunc manpage for more information about the open( ) function.) Next, the code prepares the lines of text it wants to prepend to the head of the file and assigns them and the content of the file to the @lines array. Now we have our data ready to be written back to the file, so we seek( ) to the start of the file and truncate( ) it to zero size. Truncating is necessary when there's a chance the file might shrink. In our example, the file always grows, so in this case there is actually no need to truncate it; however, it's good practice to always use truncate( ), as you never know what changes your code might undergo in the future, and truncate( ) doesn't significantly affect performance. Finally, we write the data back to the file and close it, which unlocks it as well. Did you notice that we created the text lines to be prepended as close to the place of usage as possible? This complies with good "locality of code" style, but it makes the critical section longer. In cases like this, you should sacrifice style in order to make the critical section as short as possible. An improved version of this script with a shorter critical section is shown in Example 6-33. Example 6-33. critical_section_ex2.pl use Fcntl qw(:flock); use Symbol; my @lines = ( qq{Complete documentation for Perl, including FAQ lists,\n}, qq{should be found on this system using 'man perl' or\n}, qq{'perldoc perl'. If you have access to the Internet, point\n}, qq{your browser at http://www.perl.com/, the Perl Home Page.\n}, ); my $fh = gensym; open $fh, "+>>/tmp/foo" or die $!; # start critical section flock $fh, LOCK_EX; seek $fh, 0, 0; push @lines, <$fh>; seek $fh, 0, 0; truncate $fh, 0; print $fh @lines; close $fh; # close unlocks the file # end critical section There are two important differences. First, we prepared the text lines to be prepended before the file is locked. Second, rather than creating a new array and copying lines from one array to another, we appended the file directly to the @lines array. 6.9.2.2 Safe resource locking and cleanup code Now let's get back to this section's main issue, safe resource locking. If you don't make a habit of closing all files that you open, you may encounter many problems (unless you use the Apache::PerlRun handler, which does the cleanup for you). An open file that isn't closed can cause file-descriptor leakage. Since the number of file descriptors available is finite, at some point you will run out of them and your service will fail. This will happen quite fast on a heavily used server. You can use system utilities to observe the opened and locked files, as well as the processes that have opened (and locked) the files. On FreeBSD, use the fstat utility. On many other Unix flavors, use lsof. On systems with a /proc filesystem, you can see the opened file descriptors under /proc/PID/fd/, where PID is the actual process ID. However, file-descriptor leakage is nothing compared to the trouble you will give yourself if the code terminates and the file remains locked. Any other process requesting a lock on the same file (or resource) will wait indefinitely for it to become unlocked. Since this will not happen until the server reboots, all processes trying to use this resource will hang. Example 6-34 is an example of such a terrible mistake. Example 6-34. flock.pl use Fcntl qw(:flock); open IN, "+>>filename" or die "$!"; flock IN, LOCK_EX; # do something # quit without closing and unlocking the file Is this safe code? Nowe forgot to close the file. So let's add the close( ), as in Example 6-35. Example 6-35. flock2.pl use Fcntl qw(:flock); open IN, "+>>filename" or die "$!"; flock IN, LOCK_EX; # do something close IN; Is it safe code now? Unfortunately, it is not. If the user aborts the request (for example, by pressing the browser's Stop or Reload buttons) during the critical section, the script will be aborted before it has had a chance to close( ) the file, which is just as bad as if we forgot to close it. In fact, if the same process runs the same code again, an open( ) call will close( ) the file first, which will unlock the resource. This is because IN is a global variable. But it's quite possible that the process that created the lock will not serve the same request for a while, since it might be busy serving other requests. During that time, the file will be locked for other processes, making them hang. So relying on the same process to reopen the file is a bad idea. This problem happens only if you use global variables as file handles. Example 6-36 has the same problem. Example 6-36. flock3.pl use Fcntl qw(:flock); use Symbol ( ); use vars qw($fh); $fh = Symbol::gensym( ); open $fh, "+>>filename" or die "$!"; flock $fh, LOCK_EX; # do something close $fh; $fh is still a global variable, and therefore the code using it suffers from the same problem. The simplest solution to this problem is to always use lexically scoped variables (created with my( )). The lexically scoped variable will always go out of scope (assuming that it's not used in a closure, as explained in the beginning of this chapter), whether the script gets aborted before close( ) is called or you simply forgot to close( ) the file. Therefore, if the file was locked, it will be closed and unlocked. Example 6-37 is a good version of the code. Example 6-37. flock4.pl use Fcntl qw(:flock); use Symbol ( ); my $fh = Symbol::gensym( ); open $fh, "+>>filename" or die "$!"; flock $fh, LOCK_EX; # do something close $fh; If you use this approach, please don't conclude that you don't have to close files anymore because they are automatically closed for you. Not closing files is bad style and should be avoided. Note also that Perl 5.6 provides a Symbol.pm-like functionality as a built-in feature, so you can write: open my $fh, ">/tmp/foo" or die $!; and $fh will be automatically vivified as a valid filehandle. You don't need to use Symbol::gensym and Apache::gensym anymore, if backward compatibility is not a requirement. You can also use IO::* modules, such as IO::File or IO::Dir. These are much bigger than the Symbol module (as a matter of fact, these modules use the Symbol module themselves) and are worth using for files or directories only if you are already using them for the other features they provide. Here is an example of their usage: use IO::File; use IO::Dir; my $fh = IO::File->new(">filename"); my $dh = IO::Dir->new("dirname"); Alternatively, there are also the lighter FileHandle and DirHandle modules. If you still have to use global filehandles, there are a few approaches you can take to clean up in the case of abnormal script termination. If you are running under Apache::Registry and friends, the END block will perform the cleanup work for you. You can use END in the same way for scripts running under mod_cgi, or in plain Perl scripts. Just add the cleanup code to this block, and you are safe. For example, if you work with DBM files, it's important to flush the DBM buffers by calling a sync( ) method: END { # make sure that the DB is flushed $dbh->sync( ); } Under mod_perl, the above code will work only for Apache::Registry and Apache::PerlRun scripts. Otherwise, execution of the END block is postponed until the process terminates. If you write a handler in the mod_perl API, use the register_cleanup( ) method instead. It accepts a reference to a subroutine as an argument. You can rewrite the DBM synchronization code in this way: $r->register_cleanup(sub { $dbh->sync( ) }); This will work under Apache::Registry as well. Even better would be to check whether the client connection has been aborted. Otherwise, the cleanup code will always be executed, and for normally terminated scripts, this may not be what you want. To perform this check, use: $r->register_cleanup( # make sure that the DB is flushed sub { $dbh->sync( ) if Apache->request->connection->aborted( ); } ); Or, if using an END block, use: END { # make sure that the DB is flushed $dbh->sync( ) if Apache->request->connection->aborted( ); } Note that if you use register_cleanup( ), it should be called at the beginning of the script or as soon as the variables you want to use in this code become available. If you use it at the end of the script, and the script happens to be aborted before this code is reached, no cleanup will be performed. For example, CGI.pm registers a cleanup subroutine in its new( ) method: sub new { # code snipped if ($MOD_PERL) { Apache->request->register_cleanup(\&CGI::_reset_globals); undef $NPH; } # more code snipped } Another way to register a section of cleanup code for mod_perl API handlers is to use PerlCleanupHandler in the configuration file: <Location /foo> SetHandler perl-script PerlHandler Apache::MyModule PerlCleanupHandler Apache::MyModule::cleanup( ) Options ExecCGI </Location> Apache::MyModule::cleanup performs the cleanup. 6.10 Handling Server Timeout Cases and Working with $SIG{ALRM} Similar to the case where a user aborts the script execution by pressing the Stop button, the browser itself might abort the script if it hasn't returned any output after a certain timeout period (usually a few minutes). Sometimes scripts perform very long operations that might take longer than the client's timeout. This can happen when performing full searches of a large database with no full search support. Another example is a script interacting with external applications whose prompt reponse time isn't guaranteed. Consider a script that retrieves a page from another site and does some processing on it before it gets presented to the user. Obviously, nothing guarantees that the page will be retrieved fast, if at all. In this situation, use $SIG{ALRM} to prevent the timeouts: my $timeout = 10; # seconds eval { local $SIG{ALRM} = sub { die "Sorry, timed out. Please try again\n" }; alarm $timeout; # some operation that might take a long time to complete alarm 0; }; die $@ if $@; In this code, we run the operation that might take a long time to complete inside an eval block. First we initialize a localized ALRM signal handler, which resides inside the special %SIG hash. If this handler is triggered, it will call die( ), and the eval block will be aborted. You can then do what you want with itin our example, we chose to abort the execution of the script. In most cases, you will probably want to report to the user that the operation has timed out. The actual operation is placed between two alarm( ) calls. The first call starts the clock, and the second cancels it. The clock is running for 10 seconds in our example. If the second alarm( ) call doesn't occur within 10 seconds, the SIGALRM signal is sent and the handler stored in $SIG{ALRM} is called. In our case, this will abort the eval block. If the operation between the two alarm( )s completes in under 10 seconds, the alarm clock is stopped and the eval block returns successfully, without triggering the ALRM handler. Notice that only one timer can be used at a given time. alarm( )'s returned value is the amount of time remaining in the previous timer. So you can actually roughly measure the execution time as a side effect. It is usually a mistake to intermix alarm( ) and sleep( ) calls. sleep( ) may be internally implemented in your system with alarm( ), which will break your original alarm( ) settings, since every new alarm( ) call cancels the previous one. Finally, the actual time resolution may be imprecise, with the timeout period being accurate to plus or minus one second. You may end up with a timeout that varies between 9 and 11 seconds. For granularity finer than one second, you can use Perl's four-argument version of select( ), leaving the first three arguments undefined. Other techniques exist, but they will not help with the task in question, in which we use alarm( ) to implement timeouts. 6.11 Generating Correct HTTP Headers An HTTP response header consists of at least two fields: HTTP response and MIME-type header Content-Type: HTTP/1.0 200 OK Content-Type: text/plain After adding a newline, you can start printing the content. A more complete response includes the date timestamp and server type. For example: HTTP/1.0 200 OK Date: Tue, 10 Apr 2001 03:01:36 GMT Server: Apache/1.3.19 (Unix) mod_perl/1.25 Content-Type: text/plain To notify clients that the server is configured with KeepAlive Off, clients must be told that the connection will be closed after the content has been delivered: Connection: close There can be other headers as well, such as caching control headers and others specified by the HTTP protocol. You can code the response header with a single print( ) statement: print qq{HTTP/1.1 200 OK Date: Tue, 10 Apr 2001 03:01:36 GMT Server: Apache/1.3.19 (Unix) mod_perl/1.25 Connection: close Content-Type: text/plain }; or with a "here"-style print( ): print <<'EOT'; HTTP/1.1 200 OK Date: Tue, 10 Apr 2001 03:01:36 GMT Server: Apache/1.3.19 (Unix) mod_perl/1.25 Connection: close Content-type: text/plain EOT Don't forget to include two newlines at the end of the HTTP header. With the help of Apache::Util::ht_time( ), you can get the right timestamp string for the Date: field. If you want to send non-default headers, use the header_out( ) method. For example: $r->header_out("X-Server" => "Apache Next Generation 10.0"); $r->header_out("Date" => "Tue, 10 Apr 2001 03:01:36 GMT"); When the headers setting is completed, the send_http_header( ) method will flush the headers and add a newline to designate the start of the content. $r->send_http_header; Some headers have special aliases. For example: $r->content_type('text/plain'); is the same as: $r->header_out("Content-Type" => "text/plain"); but additionally sets some internal flags used by Apache. Whenever special-purpose methods are available, you should use those instead of setting the header directly. A typical handler looks like this: use Apache::Constants qw(OK); $r->content_type('text/plain'); $r->send_http_header; return OK if $r->header_only; To be compliant with the HTTP protocol, if the client issues an HTTP HEAD request rather than the usual GET, we should send only the HTTP header, the document body. When Apache receives a HEAD request, header_only( ) returns true. Therefore, in our example the handler returns immediately after sending the headers. In some cases, you can skip the explicit content-type setting if Apache figures out the right MIME type based on the request. For example, if the request is for an HTML file, the default text/html will be used as the content type of the response. Apache looks up the MIME type in the mime.types file. You can always override the default content type. The situation is a little bit different with Apache::Registry and similar handlers. Consider a basic CGI script: print "Content-type: text/plain\n\n"; print "Hello world"; By default, this won't work, because it looks like normal text, and no HTTP headers are sent. You may wish to change this by adding: PerlSendHeader On in the Apache::Registry <Location> section of your configuration. Now the response line and common headers will be sent in the same way they are by mod_cgi. Just as with mod_cgi, even if you set PerlSendHeader On, the script still needs to send the MIME type and a terminating double newline: print "Content-type: text/html\n\n"; The PerlSendHeader On directive tells mod_perl to intercept anything that looks like a header line (such as Content-Type: text/plain) and automatically turn it into a correctly formatted HTTP header, much like CGI scripts running under mod_cgi. This feature allows you to keep your CGI scripts unmodified. You can use $ENV{PERL_SEND_HEADER} to find out whether PerlSendHeader is On or Off. if ($ENV{PERL_SEND_HEADER}) { print "Content-type: text/html\n\n"; } else { my $r = Apache->request; $r->content_type('text/html'); $r->send_http_header; } Note that you can always use the code in the else part of the above example, whether the PerlSendHeader directive is On or Off. If you use CGI.pm's header( ) function to generate HTTP headers, you do not need to activate this directive because CGI.pm detects mod_perl and calls send_http_header( ) for you. There is no free lunchyou get the mod_cgi behavior at the expense of the small but finite overhead of parsing the text that is sent. Note that mod_perl makes the assumption that individual headers are not split across print( ) statements. The Apache::print( ) routine must gather up the headers that your script outputs in order to pass them to $r->send_http_header. This happens in src/modules/perl/Apache.xs (print( )) and Apache/Apache.pm (send_cgi_header( )). There is a shortcut in therenamely, the assumption that each print( ) statement contains one or more complete headers. If, for example, you generate a Set-Cookie header using multiple print( ) statements, like this: print "Content-type: text/plain\n"; print "Set-Cookie: iscookietext\; "; print "expires=Wednesday, 09-Nov-1999 00:00:00 GMT\; "; print "path=\/\; "; print "domain=\.mmyserver.com\; "; print "\n\n"; print "Hello"; the generated Set-Cookie header is split over a number of print( ) statements and gets lost. The above example won't work! Try this instead: my $cookie = "Set-Cookie: iscookietext\; "; $cookie .= "expires=Wednesday, 09-Nov-1999 00:00:00 GMT\; "; $cookie .= "path=\/\; "; $cookie .= "domain=\.mmyserver.com\; "; print "Content-type: text/plain\n", print "$cookie\n\n"; print "Hello"; Using special-purpose cookie generator modules (for example, Apache::Cookie or CGI::Cookie) is an even cleaner solution. Sometimes when you call a script you see an ugly "Content-Type: text/html" displayed at the top of the page, and often the HTML content isn't rendered correctly by the browser. As you have seen above, this generally happens when your code sends the headers twice. If you have a complicated application in which the header might be sent from many different places depending on the code logic, you might want to write a special subroutine that sends a header and keeps track of whether the header has already been sent. You can use a global variable to flag that the header has already been sent, as shown in Example 6-38. Example 6-38. send_header.pl use strict; use vars qw($header_printed); $header_printed = 0; print_header("text/plain"); print "It worked!\n"; print_header("text/plain"); sub print_header { return if $header_printed; my $type = shift || "text/html"; $header_printed = 1; my $r = Apache->request; $r->content_type($type); $r->send_http_header; } 1; $header_printed serves as a Boolean variable, specifying whether the header was sent or not. It gets initialized to false (0) at the beginning of each code invocation. Note that the second invocation of print_header( ) within the same request will immediately return, since $header_printed will become true after print_header( ) is executed for the first time in the same request. You can continue to improve this subroutine even further to handle additional headers, such as cookies. 6.12 Method Handlers: The Browse and See, Browse and View Example Let's look at an example of the method-handler concepts presented in Chapter 4. Suppose you need to implement a handler that allows browsing the files in the document root and beneath. Directories should be browsable (so you can move up and down the directory tree), but files should not be viewable (so you can see the available files, but you cannot click to view them). So let's write a simple file browser. We know what customers are like, so we suspect that the customer will ask for similar customized modules pretty soon. To avoid having to duplicate our work later, we decide to start writing a base class whose methods can easily be overridden as needed. Our base class is called Apache::BrowseSee. We start the class by declaring the package and using the strict pragma: package Apache::BrowseSee; use strict; Next, we import common constants (e.g., OK, NOT_FOUND, etc.), load the File::Spec::Functions and File::Basename modules, and import a few path-manipulation functions that we are going to use: use Apache::Constants qw(:common); use File::Spec::Functions qw(catdir canonpath curdir updir); use File::Basename 'dirname'; Now let's look at the functions. We start with the simple constructor: sub new { bless { }, shift;} The real entry point, the handler, is prototyped as ($$). The handler starts by instantiating its object, if it hasn't already been done, and storing the $r object, so we don't need to pass it to the functions as an argument: sub handler ($$) { my($self, $r) = @_; $self = $self->new unless ref $self; $self->{r} = $r; Next we retrieve the path_info element of the request record: $self->{dir} = $r->path_info || '/'; For example, if the request was /browse/foo/bar, where /browse is the location of the handler, the path_info element will be /foo/bar. The default value / is used when the path is not specified. Then we reset the entries for dirs and files: $self->{dirs} = { }; $self->{files} = { }; This is needed because it's possible that the $self object is created outside the handler (e.g., in the startup file) and may persist between requests. Now an attempt to fetch the contents of the directory is made: eval { $self->fetch( ) }; return NOT_FOUND if $@; If the fetch( ) method dies, the error message is assigned to $@ and we return NOT_FOUND. You may choose to approach it differently and return an error message explaining what has happened. You may also want to log the event before returning: warn($@), return NOT_FOUND if $@; Normally this shouldn't happen, unless a user messes with the arguments (something you should always be on the lookout for, because they will do it). When the fetch( ) function has completed successfully, all that's left is to send the HTTP header and start of the HTML via the head( ) method, render the response, send the end of the HTML via tail( ),[4] and finally to return the OK constant to tell the server that the request has been fully answered: [4] This could perhaps be replaced by a templating system. See Appendix D for more information about the Template Toolkit. $self->head; $self->render; $self->tail; return OK; } The response is generated by three functions. The head( ) method is a very simple oneit sends the HTTP header text/html and prints an HTML preamble using the current directory name as a title: sub head { my $self = shift; $self->{r}->send_http_header("text/html"); print "<html><head><title>Dir: $self->{dir}</title><head><body>"; } The tail( ) method finishes the HTML document: sub tail { my $self = shift; print "</body></html>"; } The fetch( ) method reads the contents of the directory stored in the object's dir attribute (relative to the document root) and then sorts the contents into two groups, directories and files: sub fetch { my $self = shift; my $doc_root = Apache->document_root; my $base_dir = canonpath( catdir($doc_root, $self->{dir})); my $base_entry = $self->{dir} eq '/' ? '' : $self->{dir}; my $dh = Apache::gensym( ); opendir $dh, $base_dir or die "Cannot open $base_dir: $!"; for (readdir $dh) { next if $_ eq curdir( ); # usually '.' my $full_dir = catdir $base_dir, $_; my $entry = "$base_entry/$_"; if (-d $full_dir) { if ($_ eq updir( )) { # '..' $entry = dirname $self->{dir}; next if catdir($base_dir, $entry) eq $doc_root; } $self->{dirs}{$_} = $entry; } else { $self->{files}{$_} = $entry; } } closedir $dh; } By using canonpath( ), we make sure that nobody messes with the path_info element, by eliminating successive slashes and "/."s on Unix and taking appropriate actions on other operating systems. It's important to use File::Spec and other cross-platform functions when developing applications. While looping through the directory entries, we skip over the current directory entry using the curdir( ) function imported from File::Spec::Functions (which is equivalent to . on Unix) and handle the parent directory entry specially by matching the updir( ) function (which is equivalent to .. on Unix). The function dirname( ) gives us the parent directory, and afterward we check that this directory is different from the document root. If it's the same, we skip this entry. Note that since we use the path_info element to pass the directory relative to the document root, we rely on Apache to handle the case when users try to mess with the URL and add .. to reach files they aren't supposed to reach. Finally, let's look at the render( ) method: sub render { my $self = shift; print "<p>Current Directory: <i>$self->{dir}</i><br>"; my $location = $self->{r}->location; print qq{<a ="$location$self->{dirs}{$_}">$_</a><br>} for sort keys %{ $self->{dirs} || { } }; print qq{$_<br>} for sort keys %{ $self->{files} || { } }; } The render( ) method actually takes the files and directories prepared in the fetch( ) method and displays them to the user. First the name of the current directory is displayed, followed by the directories and finally the files. Since the module should allow browsing of directories, we hyperlink them. The files aren't linked, since we are in "see but don't touch" mode.[5] [5] In your real code you should also escape HTML- and URI-unsafe characters in the filenames (e.g., <, >, &, ", ', etc.) by using the Apache::Util::escape_html and Apache::Util::escape_uri functions. Finally, we finish the package with 1; to make sure that the module will be successfully loaded. The _ _END_ _ token allows us to put various notes and POD documentation after the program, where Perl won't complain about them. 1; _ _END_ _ Example 6-39 shows how the whole package looks. Example 6-39. Apache/BrowseSee.pm package Apache::BrowseSee; use strict; use Apache::Constants qw(:common); use File::Spec::Functions qw(catdir canonpath curdir updir); use File::Basename 'dirname'; sub new { bless {}, shift;} sub handler ($$) { my($self, $r) = @_; $self = $self->new unless ref $self; $self->{r} = $r; $self->{dir} = $r->path_info || '/'; $self->{dirs} = {}; $self->{files} = {}; eval { $self->fetch( ) }; return NOT_FOUND if $@; $self->head; $self->render; $self->tail; return OK; } sub head { my $self = shift; $self->{r}->send_http_header("text/html"); print "<html><head><title>Dir: $self->{dir}</title><head><body>"; } sub tail { my $self = shift; print "</body></html>"; } sub fetch { my $self = shift; my $doc_root = Apache->document_root; my $base_dir = canonpath( catdir($doc_root, $self->{dir})); my $base_entry = $self->{dir} eq '/' ? '' : $self->{dir}; my $dh = Apache::gensym( ); opendir $dh, $base_dir or die "Cannot open $base_dir: $!"; for (readdir $dh) { next if $_ eq curdir( ); my $full_dir = catdir $base_dir, $_; my $entry = "$base_entry/$_"; if (-d $full_dir) { if ($_ eq updir( )) { $entry = dirname $self->{dir}; next if catdir($base_dir, $entry) eq $doc_root; } $self->{dirs}{$_} = $entry; } else { $self->{files}{$_} = $entry; } } closedir $dh; } sub render { my $self = shift; print "Current Directory: <i>$self->{dir}</i><br>"; my $location = $self->{r}->location; print qq{<a ="$location$self->{dirs}{$_}">$_</a><br>} for sort keys %{ $self->{dirs} || {} }; print qq{$_<br>} for sort keys %{ $self->{files} || {} }; } 1; _ _END_ _ This module should be saved as Apache/BrowseSee.pm and placed into one of the directories in @INC. For example, if /home/httpd/perl is in your @INC, you can save it in /home/httpd/perl/Apache/BrowseSee.pm. To configure this module, we just add the following snippet to httpd.conf: PerlModule Apache::BrowseSee <Location /browse> SetHandler perl-script PerlHandler Apache::BrowseSee->handler </Location> Users accessing the server from /browse can now browse the contents of your server from the document root and beneath but cannot view the contents of the files (see Figure 6-2). Figure 6-2. The files can be browsed but not viewed Now let's say that as soon as we get the module up and running, the client comes back and tells us he would like us to implement a very similar application, except that files should now be viewable (clickable). This is because later he wants to allow only authorized users to read the files while letting everybody see what he has to offer. We knew that was coming, remember? Since we are lazy and it's not exciting to write the same code again and again, we will do the minimum amount of work while still keeping the client happy. This time we are going to implement the Apache::BrowseRead module: package Apache::BrowseRead; use strict; use base qw(Apache::BrowseSee); We place the new module into Apache/BrowseRead.pm, declare a new package, and tell Perl that this package inherits from Apache::BrowseSee using the base pragma. The last line is roughly equivalent to: BEGIN { require Apache::BrowseSee; @Apache::BrowseRead::ISA = qw(Apache::BrowseSee); } Since this class is going to do the same job as Apache::BrowseSee, apart from rendering the file listings differently, all we have to do is override the render( ) method: sub render { my $self = shift; print "<p>Current Directory: <i>$self->{dir}</i><br>"; my $location = $self->{r}->location; print qq{<a ="$location$self->{dirs}{$_}">$_</a><br>} for sort keys %{ $self->{dirs} || { } }; print qq{<a ="$self->{files}{$_}">$_</a><br>} for sort keys %{ $self->{files} || { } }; } As you can see, the only difference here is that we link to the real files now. We complete the package as usual with 1; and _ _END_ _: 1; _ _END_ _ Example 6-40 shows the whole package. Example 6-40. Apache/BrowseRead.pm package Apache::BrowseRead; use strict; use base qw(Apache::BrowseSee); sub render { my $self = shift; print "<p>Current Directory: <i>$self->{dir}</i><br>"; my $location = $self->{r}->location; print qq{<a ="$location$self->{dirs}{$_}">$_</a><br>} for sort keys %{ $self->{dirs} || {} }; print qq{<a ="$self->{files}{$_}">$_</a><br>} for sort keys %{ $self->{files} || {} }; } 1; _ _END_ _ Finally, we should add a new configuration section in httpd.conf: PerlModule Apache::BrowseRead <Location /read> SetHandler perl-script PerlHandler Apache::BrowseRead->handler </Location> Now, when accessing files through /read, we can browse and view the contents of the files (see Figure 6-3). Once we add some authentication/authorization methods, we will have a server where everybody can browse, but only privileged users can read. Figure 6-3. The files can be browsed and read You might be wondering why you would write a special module to do something Apache itself can already do for you. First, this was an example on using method handlers, so we tried to keep it simple while showing some real code. Second, this example can easily be adapted and extendedfor example, it can handle virtual files that don't exist on the filesystem but rather are generated on the fly and/or fetched from the database, and it can easily be changed to do whatever you (or your client) want to do, instead of what Apache allows. Оставьте свой комментарий ! Ваше имя: Комментарий: Оба поля являются обязательными  Автор   Комментарий к данной статье