Xavier Robin – Tag – Programming

Deep Learning of MNIST handwritten digits

2022-06-11T16:39:25+02:00

In this document I am going create a video showing the training of the inner-most layer of Deep Belief Network (DBN) using the MNIST dataset of handwritten digits. I will use our DeepLearning R package that implements flexible DBN architectures with an object-oriented interface.

MNIST

The MNIST dataset is a database of handwritten digits with 60,000 training images and 10,000 testing images. You can learn everything about it on Wikipedia. In short, it is the go-to dataset to train and test handwritten digit recognition machine learning algorithms.

I made an R package for easy access, named mnist. The easiest way to install it is with devtools. If you don't have it already, let's first install devtools:

if (!require("devtools")) {install.packages("devtools")}

Now we can install mnist:

devtools::install_github("xrobin/mnist")

PCA

In order to see what the dataset looks like, let's use PCA to reduce it to two dimensions.

pca <- prcomp(mnist$train$x)
plot.mnist(
	prediction = predict(pca, mnist$test$x),
	reconstruction = tcrossprod(
		predict(pca, mnist$test$x)[,1:2], pca$rotation[,1:2]),
	highlight.digits = c(72, 3, 83, 91, 6688, 7860, 92, 1, 180, 13))

Let's take a minute to describe this plot. The central scatterplot shows first two components of the PCA of all digits in the test set. On the left hand side, I picked 10 representative digits from the test set to highlight, which are shown as larger circles in the central scatterplot. On the left are the "reconstructed digits", which were reconstructed from the two first dimensions of the PCA. While we can see some digit-like structures, it is basically impossible to recognize them. We can see some separation of the digits in the 2D space as well, but it is pretty weak and some pairs cannot be distinguished at all (like 4 and 9). Of course the reconstructions would look much better had we kept all PCA dimensions, but so much for dimensionality reduction.

Deep Learning

Now let's see if we can do better with Deep Learning. We'll use a classical Deep Belief Network (DBN), based on Restricted Boltzmann Machines (RBM) similar to what Hinton described back in 2006 (Hinton & Salakhutdinov, 2006). The training happens in two steps: a pre-training step with contrastive divergence stochastic gradient descent brings the network to a reasonable starting point for a more conventional conjugate gradient optimization (hereafter referred to as fine-tuning).

I implemented this algorithm with a few modifications in an R package which is available on GitHub. The core of the processing is done in C++ with RcppEigen (Bates & Eddelbuettel, 2013) for higher speed. Using devtools again:

devtools::install_github("xrobin/DeepLearning")

We will use this code to train a 5 layers deep network, that reduces the digits to an abstract, 2D representation. By looking at this last layer throughout the training process we can start to understand how the network learns to recognize digits. Let's start by loading the required packages and the MNIST dataset, and create the DBN.

library(DeepLearning)
library(mnist)
data(mnist)

dbn <- DeepBeliefNet(Layers(c(784, 1000, 500, 250, 2),
	input = "continuous", output = "gaussian"),
	initialize = "0")

We just created the 5-layers DBN, with continuous, 784 nodes input (the digit image pixels), and a 2 nodes, gaussian output. It is initialized with 0, but we could have left out the initialize to start from a random initilization (Bengio et al., 2007). Before we go, let's define a few useful variables:

output.folder <- "video" # Where to save the output
maxiters.pretrain <- 1e6  # Number of pre-training iterations
maxiters.train <- 10000 # Number of fine-tuning iterations
run.training <- run.images <- TRUE # Turn any of these off 
# Which digits to highlight and reconstruct
highlight.digits = c(72, 3, 83, 91, 6688, 7860, 92, 1, 180, 13)

We'll also need the following function to show the elapsed time:

format.timediff <- function(start.time) {
    diff = as.numeric(difftime(Sys.time(), start.time, units="mins"))
    hr <- diff%/%60
    min <- floor(diff - hr * 60)
    sec <- round(diff%%1 * 60,digits=2)
    return(paste(hr,min,sec,sep=':'))
}

Pre-training

Initially, the network is a stack of RBMs that we need to pre-train one by one. Hinton & Salakhutdinov (2006) showed that this step is critical to train deep networks. We will use 1000000 iterations (maxiters.pretrain) of contrastive divergence, which takes a couple of days on a modern CPU. Let's start with the first three RBMs:

First three RBMs

if (run.training) {
	sprintf.fmt.iter <- sprintf("%%0%dd", nchar(sprintf("%d", maxiters.pretrain)))
	
	mnist.data.layer <- mnist
	for (i in 1:3) {

We define a diag function that will simply print where we are in the training. Because this function will be called a million times (maxiters.pretrain), we can use rate = "accelerate" to slow down the printing over time and save a few CPU cycles.

		diag <- list(rate = "accelerate", data = NULL, f = function(rbm, batch, data, iter, batchsize, maxiters, layer) {
			print(sprintf("%s[%s/%s] in %s", layer, iter, maxiters, format.timediff(start.time)))
		})

We can get the current RBM, and we will work on it directly. Let's save it for good measure, as well as the current time for the progress function:

		rbm <- dbn[[i]]
		save(rbm, file = file.path(output.folder, sprintf("rbm-%s-%s.RData", i, "initial")))
		start.time <- Sys.time()

Now we can start the actual pre-training:

		rbm <- pretrain(rbm, mnist.data.layer$train$x,
			penalization = "l2", lambda=0.0002, momentum = c(0.5, 0.9),
			epsilon=c(.1, .1, .1, .001)[i], batchsize = 100, maxiters=maxiters.pretrain,
			continue.function = continue.function.always, diag = diag)

This can take some time, especially for the first layers which are larger. Once it is done, we predict the data through this RBM for the next layer and save the results:

		mnist.data.layer$train$x <- predict(rbm, mnist.data.layer$train$x)
		mnist.data.layer$test$x <- predict(rbm, mnist.data.layer$test$x)
		save(rbm, file = file.path(output.folder, sprintf("rbm-%s-%s.RData", i, "final")))
		dbn[[i]] <- rbm
	}

Last RBM

This is very similar to the previous three, but note that we save the RBM within the diag function. We could generate the plot directly, but it is easier to do it later once we have some idea about the final axis we will need. Please note the rate = "accelerate" here. You probably don't want to save a million RBM objects on your hard drive, both for speed and space reasons.

	rbm <- dbn[[4]]
	print(head(rbm$b))
	diag <- list(rate = "accelerate", data = NULL, f = function(rbm, batch, data, iter, batchsize, maxiters, layer) {
		save(rbm, file = file.path(output.folder, sprintf("rbm-4-%s.RData", sprintf(sprintf.fmt.iter, iter))))
		print(sprintf("%s[%s/%s] in %s", layer, iter, maxiters, format.timediff(start.time)))
	})
	save(rbm, file = file.path(output.folder, sprintf("rbm-%s-%s.RData", 4, "initial")))
	start.time <- Sys.time()
	rbm <- pretrain(rbm, mnist.data.layer$train$x,  penalization = "l2", lambda=0.0002,
		epsilon=.001, batchsize = 100, maxiters=maxiters.pretrain,
		continue.function = continue.function.always, diag = diag)
	save(rbm, file = file.path(output.folder, sprintf("rbm-4-%s.RData", "final")))
	dbn[[4]] <- rbm

If we were not querying the last layer, we could have pre-trained the entire network at once with the following call:

	dbn <- pretrain(dbn, mnist.data.layer$train$x, 
		penalization = "l2", lambda=0.0002, momentum = c(0.5, 0.9),
		epsilon=c(.1, .1, .1, .001), batchsize = 100, 
		maxiters=maxiters.pretrain,
		continue.function = continue.function.always)

Pre-training parameters

Pre-training RBMs is quite sensitive to the use of proper parameters. With improper parameters, the network can quickly go crazy and start to generate infinite values. If that happens to you, you should try to tune one of the following parameters:

penalization: this is the penalty of introducing or increasing the value of a weight. We used L2 regularization, but "l1" is available if a sparser weight matrix is needed.
lambda: the regularization rate. In our experience 0.0002 works fine with the MNIST and other datasets of similar sizes such as cellular imaging data. Too small or large values will result in over- or under-fitted networks, respectively.
momentum: helps avoiding oscillatory behaviors, where the network oscillate between iterations. Allowed values can range from 0 (no momentum) to 1 (full momentum = no training). Here we used an increasing gradient of momentum which starts at 0.5 and increases linearly to 0.9, in order to stabilize the final network without compromising early training steps.
epsilon: the learning rate. Typically, 0.1 works well with binary and continuous output layers, and must be decreased to around 0.001 for gaussian outputs. Too large values will drive the network to generate infinities, while too small ones will slow down the training.
batchsize: larger batch sizes will result in smoother but slower training. Small batch sizes will make the training "jumpy", which can be compensated by lower learning rates (epsilon) or increased momentum.

Fine-tuning

This is where the real training happens. We use conjugate gradients to find the optimal solution. Again, the diag function saves the DBN. This time we use rate = "each" to save every step of the training. First we have way fewer steps, but also the training itself happen at a much more stable speed than in the pre-training, where things slow down dramatically.

	sprintf.fmt.iter <- sprintf("%%0%dd", nchar(sprintf("%d", maxiters.train)))
	diag <- list(rate = "each", data = NULL, f = function(dbn, batch, data, iter, batchsize, maxiters) {
		save(dbn, file = file.path(output.folder, sprintf("dbn-finetune-%s.RData", sprintf(sprintf.fmt.iter, iter))))
		print(sprintf("[%s/%s] in %s", iter, maxiters, format.timediff(start.time)))
	})
	save(dbn, file = file.path(output.folder, sprintf("dbn-finetune-%s.RData", "initial")))
	start.time <- Sys.time()
	dbn <- train(unroll(dbn), mnist$train$x, batchsize = 100, maxiters=maxiters.train,
		continue.function = continue.function.always, diag = diag)
	save(dbn, file = file.path(output.folder, sprintf("dbn-finetune-%s.RData", "final")))
}

And that's it, our DBN is now fully trained!

Generating the images

Now we need to read in the saved network states again, pass the data through the network (predict) and save this in HD-sized PNG file.

The first three RBMs are only loaded into the DBN

if (run.images) {
	for (i in 1:3) {
		load(file.path(output.folder, sprintf("rbm-%d-final.RData", i)))
		dbn[[i]] <- rbm
	}

The last RBM is where interesting things happen.

	for (file in list.files(output.folder, pattern = "rbm-4-.+\\.RData", full.names = TRUE)) {
		print(file)
		load(file)
		dbn[[4]] <- rbm
		iter <- stringr::str_match(file, "rbm-4-(.+)\\.RData")[,2]

We now predict and reconstruct the data, and calculate the mean reconstruction error:

		predictions <- predict(dbn, mnist$test$x)
		reconstructions <- reconstruct(dbn, mnist$test$x)
		iteration.error <- errorSum(dbn, mnist$test$x) / nrow(mnist$test$x)

Now the actual plotting. Here I selected xlim and ylim values that worked well for my training run, but your mileage may vary.

		png(sub(".RData", ".png", file), width = 1280, height = 720) # hd output
		plot.mnist(model = dbn, x = mnist$test$x, label = mnist$test$y+1, predictions = predictions, reconstructions = reconstructions,
				   ncol = 16, highlight.digits = highlight.digits,
				   xlim = c(-12.625948, 8.329168), ylim = c(-10.50657, 13.12654))
		par(family="mono")
		legend("bottomleft", legend = sprintf("Mean error = %.3f", iteration.error), bty="n", cex=3)
		legend("bottomright", legend = sprintf("Iteration = %s", iter), bty="n", cex=3)
		dev.off()
	}

We do the same with the fine-tuning:

	for (file in list.files(output.folder, pattern = "dbn-finetune-.+\\.RData", full.names = TRUE)) {
		print(file)
		load(file)
		iter <- stringr::str_match(file, "dbn-finetune-(.+)\\.RData")[,2]
		predictions <- predict(dbn, mnist$test$x)
		reconstructions <- reconstruct(dbn, mnist$test$x)
		iteration.error <- errorSum(dbn, mnist$test$x) / nrow(mnist$test$x)
		png(sub(".RData", ".png", file), width = 1280, height = 720) # hd output
		plot.mnist(model = dbn, x = mnist$test$x, label = mnist$test$y+1, predictions = predictions, reconstructions = reconstructions,
				   ncol = 16, highlight.digits = highlight.digits,
				   xlim = c(-22.81098,  27.94829), ylim = c(-17.49874,  33.34688))
		par(family="mono")
		legend("bottomleft", legend = sprintf("Mean error = %.3f", iteration.error), bty="n", cex=3)
		legend("bottomright", legend = sprintf("Iteration = %s", iter), bty="n", cex=3)
		dev.off()
	}
}

The video

I simply used ffmpeg to convert the PNG files to a video:

cd video
ffmpeg -pattern_type glob -i "rbm-4-*.png" -b:v 10000000 -y ../rbm-4.mp4
ffmpeg -pattern_type glob -i "dbn-finetune-*.png" -b:v 10000000 -y ../dbn-finetune.mp4

And that's it! Notice how the pre-training only brings the network to a state similar to that of a PCA, and the fine-tuning actually does the separation, and how it really makes the reconstructions accurate.

Application

We used this code to analyze changes in cell morphology upon drug resistance in cancer. With a 27-dimension space, we could describe all of the observed cell morphologies and predict whether a cell was resistant to ErbB-family drugs with an accuracy of 74%. The paper is available in Open Access in Cell Reports, DOI 10.1016/j.celrep.2020.108657.

Concluding remarks

In this document I described how to build and train a DBN with the DeepLearning package. I also showed how to query the internal layer, and use the generative properties to follow the training of the network on handwritten digits.

DBNs have the advantage over Convolutional Networks (CN) that they are fully generative, at least during the pre-training. They are therefore easier to query and interpret as we have demonstrated here. However keep in mind that CNs have demonstrated higher accuracies on computer vision tasks, such as the MNIST dataset.

Additional algorithmic details are available in the doc folder of the DeepLearning package.

References

Our paper, 2021: Longden J., Robin X., Engel M., et al. Deep neural networks identify signaling mechanisms of ErbB-family drug resistance from a continuous cell morphology space. Cell Reports, 2021;34(3):108657.
Bates & Eddelbuettel, 2013: Bates D, Eddelbuettel D. Fast and Elegant Numerical Linear Algebra Using the RcppEigen Package. Journal of Statistical Software, 2013;52(5):1–24.
Bengio et al., 2007: Bengio Y, Lamblin P, Popovici D, Larochelle H. Greedy layer-wise training of deep networks. Advances in neural information processing systems. 2007;19:153–60.
Hinton & Salakhutdinov, 2006: Hinton GE, Salakhutdinov RR. Reducing the Dimensionality of Data with Neural Networks. Science. 2006;313(5786):504–7.

Downloads

Php's htmlspecialchars stupid behavior

2017-02-26T14:25:02+01:00

Can php's htmlspecialchars delete your data? The answer, unfortunately, is yes.

I just updated a database server with a web interface from PHP 5.3 (in Ubuntu 12.04) to PHP 7 (Ubuntu 16.04.2). It went pretty smoothly, but after a couple of weeks, users started reporting missing data in some fields where they were expecting some. After some investigation, it turns out the curlpit is the htmlspecialchars function, which changed behaviour with the update. Given the following script:

<?php 
$string = "An e acute character: \xE9\n";
echo htmlspecialchars($string);
?>

In PHP 5.3, it would output:

An e acute character: �

Now with PHP >= 5.4, here's the output:

Yep, that's correct: the output is empty. PHP just discarded the whole string. Without even a warning!

While this is documented in the manual, this is the most stupid and destructive design I have seen in a long while. Data loss guaranteed when the user saves the page without realizing some fields are accidentally empty! How can anyone be so brain dead and design and implement such a behaviour? Without even a warning!

It turns out one has to define the encoding for the function to work with non-UTF8 characters:

htmlspecialchars($string, ENT_COMPAT,'ISO-8859-1', true);

As this is a legacy application dating back more than 15 years, I fully expect some strings to be broken beyond repair. Thus I wrote the following function to replace all the calls to htmlspecialchars:

function safe_htmlspecialchars($string) {
	$htmlstring = htmlspecialchars($string, ENT_COMPAT,'ISO-8859-1', true);
  
        if (strlen($string) > 0 && strlen($htmlstring) == 0) {
                trigger_error ("htmlspecialchars failed to convert data", E_USER_ERROR);
        }
}

Displaying an error in case of doubt is the only sensible behaviour here, and should be the default.

Moral of the story: I'm never using PHP in a new project again. And neither should you, if you value your data more than the PHP developers who clearly don't.

2011-06-02T15:15:39+02:00

Extraction du Ruby

2011-02-09T18:20:02+01:00

Il y a pas mal de temps, j'étais tombé sur le tutoriel intitulé Extraction du Ruby sur le SiteDuZero. Il abordait les points clés du langage de manière didactique et très agréable. Malheureusement, il a été supprimé par la suite.

Mais tout n'est pas perdu ! Grâce à l'archive web, j'ai pu récupérer ce tutoriel (dans sa version du 13 octobre 2007). Comme il est sous licence licence Creative Commons NC-SA, j'ai pu en faire une copie. Vous la trouverez naturellement dans le fichier Extraction du Ruby. Bonne lecture !

CPAN: Terminal does not support GetHistory / AddHistory in Ubuntu

2010-08-28T17:10:18+02:00

Using CPAN in Ubuntu Lucid Lynx (10.04), the command line history was broken and the up/down keys only triggered escape codes such as ^[[A. Additionally, the following error messages showed up on CPAN startup (only one of them at a time):

Terminal does not support GetHistory
Terminal does not support AddHistory

Term::ReadLine was correctly installed, but when I tried to install Bundle::CPAN, I got failed tests for Term::ReadLine::Perl. So I did:

look Term::ReadLine::Perl

to inspect the build folder, tried the test which actually seems to work. Installing the module from the shell with:

make install

was sucessful, and after restarting CPAN I had my terminal working properly. Anyway, it seems Term::ReadLine still isn't functionning perfectly:

perl -MTerm::ReadLine::Perl
Can't locate object method "Features" via package "Term::ReadLine::Stub" at /opt/perl-5.12.1/lib/site_perl/5.12.1/Term/ReadLine/Perl.pm line 101.
Compilation failed in require.
BEGIN failed--compilation aborted.

2010-07-03T10:22:01+02:00

ePerl syntax highlighting in Kate

2010-06-20T10:53:29+02:00

Kate is a great editor. It has an extensible syntax highlighting facility built around XML files.

As ePerl is very similar to PHP in essence, I took the existing PHP highlighting scheme and adapted it to ePerl. I also had to modify the Perl syntax file to catch the :> and !> terminations. And that's it!

Installation

Copy the two following files in your ~/.kde/share/apps/katepart/syntax/ directory:

Restart Kate. All your .epl, .eperl, .phtml and .phtm files should be highlighted. If not, open the Tools menu, and select Syntax highlighting, Script, ePerl (HTML).

Tested in Kate 3.3.2 (KDE 4.3.2 / Ubuntu 9.10 Karmic Koala).

Known bugs

You can mix <? with :> (for example) and all the other invalid combinations will be undetected. In fact, there should be separate highlighting for CGI and normal modes, but there is not. This should not be a big issue, though.

Debugging ePerl

2010-06-19T15:56:06+02:00

Last time I reported my wish to have true 500 errors upon script errors. I reported this rewrite by MarginalHacks, but also that POST data was lost.

So, I digged into the code and here are my results.

Setting the current script

ePerl reads the script from the arguments. However, in CGI mode, the script to read from is set in the environment variable, not in argument.

What is weird is that sometimes, this is unnecessary as the filename is already captured in the $ENV{'PATH_TRANSLATED'} block just before the arguments parsing. Indeed, it started working just as I first published this post. Anyway, argument parsing is then ignored, which is a problem, and the PATH_TRANSLATED does not give the filename, but a path which is not the script if you have mod_rewrite or use PATH_INFO (as I do both, you can imagine how wrong it is). So:

@@ -161,13 +164,6 @@
   $opt{'perl'} = $^X;
   $opt{'CaseDelimiters'} = 1;
 
-  if ($ENV{'PATH_TRANSLATED'}) {
-    # We're being called in a CGI environment, so @ARGV contains
-    # the search keywords, not the files or options to process
-    @files = ($ENV{'PATH_TRANSLATED'});
-    # Check for "nph-"
-    $opt{'mode'} = basename($ENV{'PATH_TRANSLATED'}) =~ /^nph-/ ? "n" : "c";
-  } else {
-
     while ($#ARGV>=0) {
       my $arg=shift(@ARGV);
       if ($arg =~ /^-(h|-help)$/) { usage(\%opt); }
@@ -209,18 +206,17 @@
     # Mode if not specified
     $opt{'mode'} = "f" unless ($opt{'mode'});
     $opt{'mode'} = "f" if ($opt{'mode'} =~ /^filter$/i);
-    $opt{'mode'} = "c" if ($opt{'mode'} =~ /^cgi$/i);
-    $opt{'mode'} = "n" if ($opt{'mode'} =~ /^nph-cgi$/i);
+    $opt{'mode'} = "c" if ($opt{'mode'} =~ /^cgi$/i || $ENV{"SCRIPT_FILENAME"});
+    $opt{'mode'} = "n" if ($opt{'mode'} =~ /^nph-cgi$/i || $ENV{"SCRIPT_SRC_PATH_FILE"} =~ /^nph/i);
     # And check for it based on PROGNAME
     $opt{'mode'} = "n" if ($PROGNAME =~ /^nph-/i);
 
-  }
-
   usage(\%opt,"Unsupported mode: $opt{'mode'}") unless ($opt{'mode'} =~ /^[fcn]$/);
   if ($opt{'mode'} ne "f") {
     CGI::Carp->import('fatalsToBrowser');	# Output HTML for errors
     $opt{'convert-entity'} = 1;
     $opt{'preprocess'} = 1;
+    @files = $ENV{"SCRIPT_FILENAME"} if $opt{'mode'} ne "f";
     if ($CGI_NEEDS_ALLOWED_FILE_EXT) {
       foreach my $file (@files) {
         usage(\%opt,"File `$file' is not allowed to be interpreted by ePerl (wrong extension!)",1)

Just remove that test! Try some other defaults as well, it seems to work, but should be more extensively tested.

Not loosing STDIN

Actually there is an option for this: --tmpfile. Which leads us to the second point:

Multiple shebang options

After adding --tmpfile to the shebang already containing --mode=CGI, I got a true 500 error from the server, and a usage report in the logs. It looks like arguments are not splitted on whitespace in the shebang. Seems to be a known bug (or even feature?). So we have to split the arguments directly in the script. Here is the diff:

@@ -169,6 +172,7 @@
     $opt{'mode'} = basename($ENV{'PATH_TRANSLATED'}) =~ /^nph-/ ? "n" : "c";
   } else {
 
+    @ARGV = split(" ", @ARGV[0]) if $#ARGV == 1; # weird behaviour in shebang: all args passed as only one, so split them here!
     while ($#ARGV>=0) {
       my $arg=shift(@ARGV);
       if ($arg =~ /^-(h|-help)$/) { usage(\%opt); }

Returning 500 code upon error

As mentionned previously, the script returns a 200 OK when an error happens in the script. This is annoying, because the page ends up indexed in Google (sample query. This can be a security issue, as the information disclosed could be used by an attacker to find a flaw in the code! (Actually it shouldn't create any flaw, it just discloses information to make it slightly easier to discover an existing flaw.) The HTTP spec defines the 500 Internal Server Error code to employ in this case of a server error. Hopefully it is an easy change:

@@ -1139,12 +1143,15 @@
 
   if ($opt_H->{'mode'} eq "n") {
     my $proto = $ENV{'SERVER_PROTOCOL'} || "HTTP/1.0";
-    print SEND_OUT "$proto 200 OK\n";
+    print SEND_OUT "$proto 500 Internal Server Error\n";
     my $server = $ENV{'SERVER_SOFTWARE'} || "unknown-server/0.0";
     print SEND_OUT "Server: $server ePerl/$VERSION Perl/$]\n";
     print SEND_OUT "Date: ".localtime(time)."\n";
     print SEND_OUT "Connection: close\n";
   }
+  else {
+    print SEND_OUT "Status: 500\n";
+  }
   print SEND_OUT <<HTML_START;
 Content-Type: text/html

Note that the 500 code is now returned in both CGI and NPH-CGI modes.

Custom error page

The last step was to customize the error page. Right, the page provides useful information, but it is especially ugly!

I introduced a new --errorscript argument. The script in argument will be called and its output displayed in place of the built-in error message. It involves several changes:

@@ -129,6 +129,9 @@
                             (If script needs to read stdin, like a post .cgi)
   -1, --eval                Run in a single process using `eval'
                             (default for MSWin32 as can't fork)
+  -S, --errorscript=PATH    use a custom error script rather than the buit-in default
+                            message. Warning: do not use this argument in the error
+                            page itself, or you could end up with an infinite loop!
   --                        Following options are args to the ePerl script
 
 );
@@ -196,6 +200,7 @@
       if ($arg =~ /^-(s|-strict)$/) { $opt{'strict'}=1; next; }
       if ($arg =~ /^-(t|-tmpfile)$/) { $opt{'tmpfile'}=1; next; }
       if ($arg =~ /^-(1|-eval)$/) { $opt{'eval'}=1; next; }
+      if ($arg =~ /^-(S|-errorscript=)(.+)?$/) { $opt{'errorscript'}=arg(); next; }
    
       if ($arg =~ /^-(r|-readme)$/) { readme(); exit(0); }
       if ($arg =~ /^-(l|-license)$/) { license(); exit(0); }
@@ -1145,12 +1190,23 @@
     print SEND_OUT "Date: ".localtime(time)."\n";
     print SEND_OUT "Connection: close\n";
   }
+  else {
+    print SEND_OUT "Status: 500\n";
+  }
+  if ($opt_H->{'errorscript'}) {
+    $ENV{'REDIRECT_STATUS'} = 500;
+    $ENV{'REDIRECT_ERROR_NOTES'} = "<pre>$error</pre>";
+    $ENV{'REDIRECT_ERROR_NOTES'} = "<pre>$error: @err</pre>" if @err;
+    my $errorscript = $opt_H->{'errorscript'};
+    print SEND_OUT `$errorscript`;
+  }
+  else {
   print SEND_OUT <<HTML_START;
 Content-Type: text/html
 
@@ -1186,6 +1242,7 @@
 </body>
 </html>
 HTML_END
+  }
 }
 
 sub readme {

Warning: do not define --errorscript to point to the script itself. If something goes wrong, you would end up in an infinite loop, I haven't included code to check that condition!

Custom error page again

Ok, let's try what happens when we die in the ePerl script… well, we see the output stop at the point we died, but no error message is displayed! This seems actually linked to the way the --tmpfile argument is processed: error output is not captured. I added a dirty hack to do that, with another temp file to hold STDERR.

@@ -503,17 +509,24 @@
 
 # Write to a tmpfile, execute that
 my $TMPFILE;
+my $TMPERRFILE;
 sub start_perl_tmpfile {
   my ($opt_H) = @_;
 
   my $file = "$TMPDIR/$PROGNAME.$$";
   usage($opt_H,"Tmpfile already exists?? [$file]",1) if (-f $file);
+  my $errfile = "$TMPDIR/$PROGNAME.err.$$";
+  usage($opt_H,"Tmperrfile already exists?? [$errfile]",1) if (-f $errfile);
 
   my $save = umask 077;		# Some added safety
   $opt_H->{'ph'} = new IO::File;
+  $opt_H->{'pherr'} = new IO::File;
   usage($opt_H,"Couldn't create tmpfile [$file]",1)
     unless $opt_H->{'ph'}->open(">$file");
+  usage($opt_H,"Couldn't create tmperrfile [$errfile]",1)
+    unless $opt_H->{'pherr'}->open(">$errfile");
   $TMPFILE = $file;
+  $TMPERRFILE = $errfile;
   umask $save;
   $SIG{'INT'}='interrupt';
   $SIG{'TERM'}='interrupt';
@@ -521,7 +534,10 @@
   $SIG{'SUSP'}='interrupt';
   $SIG{'QUIT'}='interrupt';
 }
-sub clean_tmpfile { unlink $TMPFILE if $TMPFILE && -f $TMPFILE; }
+sub clean_tmpfile {
+  unlink $TMPFILE if $TMPFILE && -f $TMPFILE;
+  unlink $TMPERRFILE if $TMPERRFILE && -f $TMPERRFILE;
+}
 sub interrupt { print STDERR "[$PROGNAME] **INTERRUPT**"; clean_tmpfile(); exit; }
 
 # Just open a normal pipe to a perl process, redirect STDOUT
@@ -797,9 +813,38 @@
     # Dangerous race condition here!
     usage($opt_H,"Tmpfile disappeared?? [$TMPFILE]",1)
       unless $TMPFILE && -r $TMPFILE;
-    system("$opt_H->{'perl'} $opt_H->{'perl_opts'} $TMPFILE @ARGV");
+    my $output = `$opt_H->{'perl'} $opt_H->{'perl_opts'} $TMPFILE @ARGV  2>$TMPERRFILE`;
     $ret = $?;
+    $opt_H->{'pherr'}->close;
+    my $exit = $ret >> 8;
+    my $int  = $ret & 127;
+    my $core = $ret & 128;
+    $exit|=0xffffff00 if $exit>>7;
+    $exit = sprintf("%d",$exit);
+	if ($exit || $int || $core) { # Ok, there was an error!
+		# read-open the error file
+		my $errfile = "$TMPDIR/$PROGNAME.err.$$";
+			usage($opt_H,"Tmperrfile already removed?? [$errfile]",1) unless (-f $errfile);
+		$opt_H->{'pherr'} = new IO::File;
+		$opt_H->{'pherr'}->open("<$errfile");
+		my $error = "";
+		$error .= "[$PROGNAME] Interpretor returned error [$exit]\n" if ($exit);
+		$error .= "[$PROGNAME] **INTERRUPT**\n" if $int;
+		$error .= "[$PROGNAME] (Core dump)\n" if $core;
+		$error .= "$opt_H->{'start_file'} syntax OK\n" if ($opt_H->{'syntax_check'} && !$ret);
+		if ($error && $opt_H->{'mode'} eq "f") {
+			print STDERR $error;
+		} elsif ($error) {
+			redirect_output($opt_H);
+			chomp $error;
+			html_error($opt_H,$error,$opt_H->{'pherr'}->getlines);
+			$opt_H->{'pherr'}->close;
+		}
+	} else {
+		print $output;
+	}
     clean_tmpfile();
+    exit($exit); # Exit here directly
 
   } elsif ($opt_H->{'eval'}) {
     # eval method

Conclusion

This new ePerl works (it's already used to generate the pages you see!) I think I've fixed the main issues I had, but I'm not fully satisfied with it. There is too much useless code (for my needs) and dirty hacks. I might come with an ePerlLite in some future, but for now it will do.

You can download the diff if you're interrested. Just patch the original eperl.pl with patch eperl.pl eperl.diff and that's it, or get the script directly (this one is additionally converted to UTF-8).

Tags cloud

2010-06-13T19:34:58+02:00

There are several CPAN modules to generate tag clouds. To cite only 3 of them:

I just added tags cloud on this site (look the new home page!) with Data::CloudWeights. HTML::TagCloud generate ugly HTML and CSS that cannot be modified. HTML::TagClouder is marked as *WARNING* Alpha software! I mean it! Not for me, thanks!

Data::CloudWeights is far the most flexible. It generates an arrayref of hashes from which you can pick size, occurences, colors and so on. I use the following subroutine to generate the cloud with a very simple and standard code:

use Data::CloudWeights;
sub tag_cloud {
	my @tags = @_;
	my $cloud = Data::CloudWeights->new;
	for my $tag (@tags) {
		# The followin line is a bit more complicated than shown here
		# $tag is a DBIx::Class entry with more columns than displayed here
		$cloud->add($tag->tag, scalar  $tag->links, "/tag/" . $tag->tag);
	}
	my $cloud_html = "";
	foreach my $tag (@{$cloud->formation}) {
		$cloud_html .= '<a href="' . $tag->{'value'} .
			'" style="font-size: ' . $tag->{'size'} . 'em">';
		$cloud_html .= $tag->{'tag'};
		$cloud_html .= '</a>';
	}
	return $cloud_html;
}

ePerl

2010-06-13T18:32:35+02:00

There are two versions of ePerl:

The former is a C wrapper around a perl module. The latter is written entirely in perl.

I was using Ralf S. Engelschall's version until now, because it is in Debian repositories. However, I wanted to return an HTTP 500 code upon error, so that Google would't index errors (as it currently does). It is hard-coded in the C code. Rather than recompiling, I tried the newer version from MarginalHacks. The error code is hard-coded as well, but it is in Perl, so easier to rewrite and to link with my standard error code.

I had to modify my shebangs (#!/usr/bin/eperl.pl --mode=CGI is fine), and also to correct an error in eperl.pl by adding

@files = $ENV{"SCRIPT_FILENAME"};

inside the

if ($opt{'mode'} ne "f") {

block (that is, between lines 220 and 224), because we don't want to use the HTTP path passed as argument in CGI mode, but rather the script file name.

Unfortunately, I quickly noted that this new ePerl looses STDIN data. That means, no POST data available in the script: and I use that for comments and contact. There is a -t argument, but it had no effect for me. I'll stick to the old ePerl for the moment, and try to make sure my code runs fine, but I'll need to have a closer look into what happens exactly with input sooner or later.