Initial commit

sub even_odd_print_gen {

    # $last is shared between the two procedures

    my ($rs1, $rs2);

    my ($last) = shift;  # Shared by the two closures below

    $rs1 = sub { # Even number printer

        if ($last % 2) {$last ++;}

        else { $last += 2};

        print "$last \n";

    };

    $rs2 = sub { # Even number printer

        if ($last % 2) {$last += 2 }

        else { $last++};

        print "$last \n";

    };

    return ($rs1, $rs2);   # Returning two anon sub references

}

($even_iter,$odd_iter) = even_odd_print_gen(10);

&$even_iter ();  # prints 12

&$odd_iter  ();  # prints 13

&$odd_iter  ();  # prints 13

&$even_iter ();  # prints 14

&$odd_iter  ();  # prints 15

sub my_srand {

    my ($seed) = @_; 

    # Returns a random number generator function

    # Being predictive, the algorithm requires you to supply a 

    # random initial value.

    my $rand = $seed; 

    return sub  {

             # Compute a new pseudo-random number based on its old value

             # This number is constrained between 0 and 1000.

             $rand = ($rand*21+1)%1000; 

    };

}

$random_iter1 = my_srand  (100);  

$random_iter2 = my_srand (1099);

for ($i = 0; $i < 100; $i++) {

    print &$random_iter1(), " ", &$random_iter2(), "\n";

}

#include "EXTERN.h"

#include <string.h>

#include <perl.h>

/*perl_call ("foo",

       "s",    "hello",

       "i",    2,

       "d",    5.4,

       "OUT",

       "i",    &i,

       "s",    buf,

       NULL);

*/

typedef struct {

    char type;       

    void *pdata;

} Out_Param;

int

perl_eval_va (char *str, ...)

{

    /* Evals a string, returns -1 if unsuccessful, else returns

     *  the number of return params

     *  char buf[10]; int a;

     *  perl_eval_va ("$a = 10; ($a, $a+1)",

     *                "i", &a,

     *                "s", buf,

     *                 NULL);

     */

    SV*       sv     = newSVpv(str,0);

    va_list   vl;

    char      *p     = NULL;  

    int       i      = 0; 

    int       nret   = 0;     /* number of return params expected*/

    int       result = 0;

    Out_Param op[20];

    int ii; double d;

    dSP;

    ENTER;

    SAVETMPS;

    PUSHMARK(sp);

    va_start (vl, str);

    while (p = va_arg(vl, char *)) {

        if ((*p != 's') && (*p != 'i') && (*p != 'd')) {

            fprintf (stderr, "perl_eval_va: Unknown option \'%c\'.\n"

                              "Did you forget a trailing NULL ?\n", *p);

            return -1;

        }

        op[nret].pdata = (void*) va_arg(vl, char *);

        op[nret++].type = *p;

    }

    va_end(vl);

    PUTBACK;

    result = perl_eval_sv(sv, (nret == 0) ? G_DISCARD :

                              (nret == 1) ? G_SCALAR  :

                                            G_ARRAY  );

    SPAGAIN;

    if (SvTRUE(GvSV(errgv))) { /* errgv == $@ */

        fprintf (stderr, "Eval error: %s", SvPV(GvSV(errgv), na)) ;

        return -1;

    }

    SvREFCNT_dec(sv);

    /*printf ("nret: %d, result: %d\n", nret, result);*/

    if (nret > result)

        nret = result;

    for (i = --nret; i >= 0; i--) {

        switch (op[i].type) {

        case 's':

            str = POPp;

            /*printf ("String: %s\n", str);*/

            strcpy((char *)op[i].pdata, str);

            break;

        case 'i':

            ii = POPi;

            /*printf ("Int: %d\n", ii);*/

            *((int *)(op[i].pdata)) = ii;

            break;

        case 'd':

            d = POPn;

            /*printf ("Double: %f\n", d);*/

            *((double *) (op[i].pdata)) = d;

            break;

        }

   }

   FREETMPS ;

   LEAVE;

   return result;

}    

int

perl_call_va (char *subname, ...)

{

    char *p;

    char *str = NULL; int i = 0; double d = 0;

    int  nret = 0; /* number of return params expected*/

    int  ax;

    int ii=0;

    Out_Param op[20];

    va_list vl;

    int out = 0;

    int result = 0;

    dSP;

    ENTER;

    SAVETMPS;

    PUSHMARK(sp);

    va_start (vl, subname);

    /*printf ("Entering perl_call %s\n", subname);*/

    while (p = va_arg(vl, char *)) {

        /*printf ("Type: %s\n", p);*/

        switch (*p)

        {

        case 's' :

            if (out) {

                op[nret].pdata = (void*) va_arg(vl, char *);

                op[nret++].type = 's';

            } else {

                str = va_arg(vl, char *);

         /*printf ("IN: String %s\n", str);*/

         ii = strlen(str);

                XPUSHs(sv_2mortal(newSVpv(str,ii)));

            }

            break;

        case 'i' :

            if (out) {

                op[nret].pdata = (void*) va_arg(vl, int *);

                op[nret++].type = 'i';

            } else {

                ii = va_arg(vl, int);

         /*printf ("IN: Int %d\n", ii);*/

                XPUSHs(sv_2mortal(newSViv(ii)));

            }

            break;

        case 'd' :

            if (out) {

                op[nret].pdata = (void*) va_arg(vl, double *);

                op[nret++].type = 'd';

            } else {

               d = va_arg(vl, double);

               /*printf ("IN: Double %f\n", d);*/

               XPUSHs(sv_2mortal(newSVnv(d)));

            }

            break;

        case 'O':

            out = 1;  /* Out parameters starting */

            break;

        default:

             fprintf (stderr, "perl_eval_va: Unknown option \'%c\'.\n"

                               "Did you forget a trailing NULL ?\n", *p);

            return 0;

        }

    }

    va_end(vl);

    PUTBACK;

    result = perl_call_pv(subname, (nret == 0) ? G_DISCARD :

                                   (nret == 1) ? G_SCALAR  :

                                                 G_ARRAY  );

    SPAGAIN;

    /*printf ("nret: %d, result: %d\n", nret, result);*/

    if (nret > result)

        nret = result;

    for (i = --nret; i >= 0; i--) {

        switch (op[i].type) {

        case 's':

            str = POPp;

            /*printf ("String: %s\n", str);*/

            strcpy((char *)op[i].pdata, str);

            break;

        case 'i':

            ii = POPi;

            /*printf ("Int: %d\n", ii);*/

            *((int *)(op[i].pdata)) = ii;

            break;

        case 'd':

            d = POPn;

            /*printf ("Double: %f\n", d);*/

            *((double *) (op[i].pdata)) = d;

            break;

        }

    }

    FREETMPS ;

    LEAVE ;

    return result;

}

 No newline at end of file

#!/opt/bin/perl

# Extracts columns of text from a file

# Usage : col [-s<n>] col-range1, col-range2, files ...

# where col-range is specified as col1-col2 (column 1 through column2) 

#         or col1+n, where n is the number of columns.

$size = 0;          # 0 => line-oriented input, else fixed format.

@files = ();        # List of files

$open_new_file = 1; # Force get_next_line() to open the first file

$debugging = 0;     # Enable with -d commmand line flag

generate_part1();  

generate_part2();

generate_part3();

col();           # sub col has now been generated. Call it !

exit(0);

#------------------------------------------------------------------

sub generate_part1 {

    # Generate the initial invariant code of sub col()

    $code  = 'sub col { my $tmp;';           # Note the single quotes

    $code .= 'while (1) {$s = get_next_line(); $col = "";';

    $delimiter = '|';

}

#------------------------------------------------------------------

sub generate_part2 {

    # Process arguments

    foreach $arg (@ARGV) {

        if (($col1, $col2) = ($arg =~ /^(\d+)-(\d+)/)) {

            $col1--;# Make it 0 based

            $offset = $col2 - $col1;

            add_range($col1, $offset);

        } elsif (($col1, $offset) = ($arg =~ /^(\d+)\+(\d+)/)) {

            $col1--;

            add_range($col1, $offset);

        } elsif ($size = ($arg =~ /-s(\d+)/)) {

            # noop

        } elsif ($arg =~ /^-d/) {

            $debugging = 1;

        } else {

            # Must be a file name

            push (@files, $arg);

        }

    }

}

#------------------------------------------------------------------

sub generate_part3 {

    $code .= 'print $col, "\n";}}';

    print $code if $debugging; # -d flag enables debugging.

    eval $code;

    if ($@) {

        die "Error ...........\n $@\n $code \n";

    }

}

#------------------------------------------------------------------

sub add_range { 

    my ($col1, $numChars) = @_;

    # substr complains (under -w) if we look past the end of a string

    # To prevent this, pad the string with spaces if necessary.

    $code .= "\$s .= ' ' x ($col1 + $numChars - length(\$s))";

    $code .= "    if (length(\$s) < ($col1+$numChars));";

    $code .= "\$tmp = substr(\$s, $col1, $numChars);";

    $code .= '$tmp .= " " x (' . $numChars .  ' - length($tmp));';

    $code .= "\$col .= '$delimiter' . \$tmp; ";

}

#------------------------------------------------------------------

sub get_next_line {

    my($buf);

  NEXTFILE:

    if ($open_new_file) {

        $file = shift @files || exit(0);

        open (F, $file) || die "$@ \n";

        $open_new_file = 0;

    }

    if ($size) {

        read(F, $buf, $size);

    } else {

        $buf = <F>;

    }

    if (! $buf) {

        close(F);

        $open_new_file = 1;

        goto NEXTFILE;

    }

    chomp($buf);

    # Convert tabs to spaces (assume tab stop width == 8)

    # expand leading tabs first  the common case

    $buf =~ s/^(\t+)/' ' x (8 * length($1))/e;

    # Now look for nested tabs. Have to expand them one at a time - hence

    # the while loop. In each iteration, a tab is replaced by the number of

    # spaces left till the next tab-stop. The loop exits when there are

    # no more tabs left

    1 while ($buf =~ s/\t/' ' x (8 - length($`)%8)/e);

    $buf;

}

while (defined($s = <>)) {          # Read a line into $s

    $result = eval $s;      # Evaluate that line

    if ($@) {               # Check for compile or run-time errors.

        print "Invalid string :\n $s";

    } else {

        print $result, "\n";

    }

}