(moved to Distribution/lib/scripts)
authorhaftmann
Mon Jun 20 11:45:40 2005 +0200 (2005-06-20)
changeset 1647240c4653a30d5
parent 16471 c487e7e8865f
child 16473 b24c820a0b85
(moved to Distribution/lib/scripts)
Admin/isa-migrate
     1.1 --- a/Admin/isa-migrate	Mon Jun 20 11:30:44 2005 +0200
     1.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.3 @@ -1,155 +0,0 @@
     1.4 -#!/usr/bin/env perl
     1.5 -#
     1.6 -# $Id$
     1.7 -# Author: Florian Haftmann, TUM
     1.8 -#
     1.9 -# A generic framework script for simple theory file migrations
    1.10 -# (under developement)
    1.11 -#
    1.12 -
    1.13 -use strict;
    1.14 -use File::Find;
    1.15 -use File::Basename;
    1.16 -use File::Copy;
    1.17 -
    1.18 -# configuration
    1.19 -my @suffices = ('\.thy');
    1.20 -my $backupext = '.bak';
    1.21 -
    1.22 -# migrator lookup hash
    1.23 -my %migrators = (
    1.24 -    id => sub {
    1.25 -        my ($file, @content) = @_;
    1.26 -    },
    1.27 -    thyheader => sub {
    1.28 -        my ($file, @content) = @_;
    1.29 -        #~ my $diag = 1;
    1.30 -        my $diag = 0;
    1.31 -        $_ = join("", @content);
    1.32 -        if (m!^theory!cgoms) {
    1.33 -            my $prelude = $`;
    1.34 -            my $thyheader = "theory";
    1.35 -            $thyheader .= skip_wscomment();
    1.36 -            if (m!\G(\S+)!cgoms) {
    1.37 -                $thyheader .= $1;
    1.38 -                $thyheader .= skip_wscomment();
    1.39 -                $diag and print "--->\n(1)>>>$thyheader<<<\n<---\n";
    1.40 -                if (m!\G(?:imports|=)!cgoms) {
    1.41 -                    $thyheader .= "imports";
    1.42 -                    $thyheader .= skip_wscomment() || " ";
    1.43 -                    $diag and print "--->\n(2)>>>$thyheader<<<\n<---\n";
    1.44 -                    while (m/\G(?!uses|files|begin|:)/cgoms && m!\G(?:[\w_]+|"[^"]+")!cgoms) {
    1.45 -                        $diag and print "--->\n(3)>>>$&<<<\n<---\n";
    1.46 -                        $thyheader .= $&;
    1.47 -                        $thyheader .= skip_wscomment();
    1.48 -                        if (m!\G\+!cgoms) {
    1.49 -                            m!\G ?!cgoms;
    1.50 -                        }
    1.51 -                        $thyheader .= skip_wscomment();
    1.52 -                        #~ if (m/\G(?!uses|files|begin|:)/cgoms) { print '!!!'; }
    1.53 -                        #~ if (m!\G[\w_]+!cgoms) { print ''; }
    1.54 -                    }
    1.55 -                    $diag and print "--->\n(4)>>>$thyheader<<<\n<---\n";
    1.56 -                }
    1.57 -                #~ m!\G.{19}!cgoms;
    1.58 -                #~ print "***$&\n";
    1.59 -                #~ die;
    1.60 -                if (m!\G(?:files|uses)!cgoms) {
    1.61 -                    $thyheader .= "uses";
    1.62 -                    $thyheader .= skip_wscomment();
    1.63 -                    $diag and print "--->\n(5)>>>$thyheader<<<\n<---\n";
    1.64 -                    while (m/\G(?!begin|:)/cgoms && m!\G(\("[^"]+"\)|"[^"]+"|[^"\s]+)!cgoms) {
    1.65 -                        $diag and print "--->\n(6)>>>$&<<<\n<---\n";
    1.66 -                        $thyheader .= $&;
    1.67 -                        $thyheader .= skip_wscomment();
    1.68 -                    }
    1.69 -                    $diag and print "--->\n(7)>>>$thyheader<<<\n<---\n";
    1.70 -                }
    1.71 -                
    1.72 -
    1.73 -                if (m!\G(?:begin|:)!cgoms) {
    1.74 -                    my $postlude = $';
    1.75 -                    if ($& eq ":") {
    1.76 -                        $thyheader .= " ";
    1.77 -                    }
    1.78 -                    $thyheader .=  "begin";
    1.79 -                    # do replacement here
    1.80 -                    if ($diag) {
    1.81 -                        print "$file:\n$thyheader\n\n";
    1.82 -                    } else {
    1.83 -                        open(OSTREAM, ">$file") or die("error opening $file");
    1.84 -                        print OSTREAM "$prelude$thyheader$postlude";
    1.85 -                        close(OSTREAM);
    1.86 -                    }
    1.87 -                }
    1.88 -            }
    1.89 -        }
    1.90 -    }
    1.91 -);
    1.92 -
    1.93 -# utility functions
    1.94 -sub skip_wscomment {
    1.95 -    my $commentlevel = 0;
    1.96 -    my @skipped = ();
    1.97 -    while () {
    1.98 -        if (m!\G\(\*!cgoms) {
    1.99 -            push(@skipped, $&);
   1.100 -            $commentlevel++;
   1.101 -        } elsif ($commentlevel > 0) {
   1.102 -            if (m!\G\*\)!cgoms) {
   1.103 -                push(@skipped, $&);
   1.104 -                $commentlevel--;
   1.105 -            } elsif (m/\G(?:
   1.106 -                        \*(?!\))|\((?!\*)|[^(*]
   1.107 -                       )*/cgomsx) {
   1.108 -                push(@skipped, $&);
   1.109 -            } else {
   1.110 -                die ("probably incorrectly nested comment");
   1.111 -            }
   1.112 -        } elsif (m!\G\s+!cgoms) {
   1.113 -            push(@skipped, $&);
   1.114 -        } else {
   1.115 -            return join('', @skipped);
   1.116 -        }
   1.117 -    }
   1.118 -}
   1.119 -
   1.120 -# process dir tree
   1.121 -sub process_tree {
   1.122 -    my ($root, $migrator, $backupext) = @_;
   1.123 -    find(sub { process($_, $migrator, $backupext) }, $root);
   1.124 -}
   1.125 -
   1.126 -# process single file
   1.127 -sub process {
   1.128 -    my ($file, $migrator, $backupext) = @_;
   1.129 -    my ($basename, $dirname, $ext) = fileparse($file, @suffices);
   1.130 -    #~ print "$file\n";
   1.131 -    if ($ext) {
   1.132 -        open(ISTREAM, $file) or die("error opening $file");
   1.133 -        my @content = <ISTREAM>;
   1.134 -        close ISTREAM;
   1.135 -        if ($backupext) {
   1.136 -            copy($file, "$file$backupext");
   1.137 -        }
   1.138 -        print "Migrating $file...\n";
   1.139 -        &$migrator($file, @content);
   1.140 -    }
   1.141 -}
   1.142 -
   1.143 -# first argument: migrator name
   1.144 -my $migrator = $migrators{shift @ARGV};
   1.145 -$migrator or die ("invalid migrator name");
   1.146 -# other arguments: files or trees
   1.147 -foreach my $fileloc (@ARGV) {
   1.148 -    -e $fileloc or die ("no file $fileloc");
   1.149 -}
   1.150 -foreach my $fileloc (@ARGV) {
   1.151 -    if (-d $fileloc) {
   1.152 -        process_tree($fileloc, $migrator, $backupext);
   1.153 -    } else {
   1.154 -        process($fileloc, $migrator, $backupext);
   1.155 -    }
   1.156 -}
   1.157 -
   1.158 -#!!! example file:
   1.159 \ No newline at end of file