create_perl_tests.pl

#!/usr/bin/perl

### $Header: /usr/local/cvsrep/cl-interpol/test/create_perl_tests.pl,v 1.2 2008/07/23 14:30:45 edi Exp $

### Copyright (c) 2003-2008, Dr. Edmund Weitz. All rights reserved.

### Redistribution and use in source and binary forms, with or without
### modification, are permitted provided that the following conditions
### are met:

###   * Redistributions of source code must retain the above copyright
###     notice, this list of conditions and the following disclaimer.

###   * Redistributions in binary form must reproduce the above
###     copyright notice, this list of conditions and the following
###     disclaimer in the documentation and/or other materials
###     provided with the distribution.

### THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
### OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
### WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
### ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
### DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
### DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
### GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
### WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
### NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
### SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

my @chars = qw(\Q \L \U \E \l \u);

sub combine {
  my $delim = shift;
  my @result = ();
  foreach my $char (@chars) {
    foreach my $string (@_) {
      push @result, "$char$delim$string";
    }
  }
  @result;
}

sub quote {
  local $_ = shift;
  s/\\/\\\\/g;
  $_;
}

print <<'HEAD';
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE-TEST; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-interpol/test/create_perl_tests.pl,v 1.2 2008/07/23 14:30:45 edi Exp $

;;; some simple tests for CL-INTERPOL which were generated by a Perl script

HEAD

foreach my $a (('Aa-', 'aA-')) {
  my $counter = 0;
  my @arr = @chars;
  while ($counter++ < 4) {
    foreach my $str (@arr) {
      print "(let ((a \"$a\"))\n";
      my $test = "\${a}$str\${a}";
      print "  (string= #?\"$test\" \"" . (quote eval "\"$test\"") . "\"))\n";
    }
    @arr = combine '${a}', @arr;
  }
}

print "\n";