G::System

GEMS

G::System::GEMS - Perl extension for blah blah blah

  use G::System::GEMS;
  blah blah blah

Stub documentation for G::System::GEMS was created by h2xs. It looks like the
author of the extension was negligent enough to leave the stub
unedited.

Blah blah blah.

Methods description

Methods code

    my $self = shift;

    &opt_default(src=>"");
    my @args=opt_get(@_);

    my $gcffile=shift @args;
    my $generate=&opt_val("src");
    my $cf;
    my $gcfname=substr((split(/\//,$gcffile))[-1],0,index(((split(/\//,$gcffile))[-1],'.')));
    my $time;
    my $script;
    my $method;
    my $param;
    my $user;
    my $switch;
    my $pkg;
    my $EXCT;
    my $tmp;
    my @koya;

    $cf=GEMS_parser("$gcffile");
    return "HOGE" if($cf eq "HOGE");

    if($generate){
	open(GNRT,">$generate");
	print GNRT '#!/usr/bin/env perl',"\n\n",'##################################################',"\n";
	print GNRT "\#  $gcfname source script\n";
	print GNRT '##################################################',"\n",'#Generated by G-language System.',"\n";
        print GNRT '#This program map gene to Genomes.',"\n",'#usage:perl This_file_name',"\n\n",'use G;',"\n\n";
    }
    
    else{
	$time=time;
	open(EXCT, ">/tmp/GEMS_$time\.pl");

	$tmp='#!/usr/bin/env perl'."\n\n".'##################################################';
	$tmp.="\n\#  $gcfname temporary script\n";
	$tmp.='##################################################'."\n".'#Generated by G-language System.';
	$tmp.="\n".'#This program is temporary script of Gene Mapping System.'."\n\n";
	$tmp.='package GEMS_'.$time."\;\n\n".'use G;'."\n".'use SubOpt;'."\n\n";
	$tmp.='sub GEMS_SRC{'."\n";
	eval{print EXCT $tmp;};
    } 
    
    foreach(keys(%{$cf})){
	next if($_ !~ /^G\d+$/);
	$script.=$cf->{$_}->{instance}.'="'.$cf->{$_}->{data}.'";'."\n";
    }
    $script.="\n";

    foreach $method (@{$cf->{Order}}){
	$tmp='';
        $switch=0;
        next if($method eq '');
        foreach $user (keys(%{$cf})){
	    next if($user !~ /^User/);
	    if($method eq $cf->{"$user"}->{code}){
	        $tmp=$method;
	        $switch=1;
	        last;
	    }
        }
        if($switch==0){
	    $tmp='&'.$method.'(';
	    @koya=keys(%{$cf->{"$method"}});
	    for(my $i=1;$i<=$##koya;$i++){
		$param="param".$i;
	        next if($param!~/^param/);
		if($cf->{"$method"}->{"$param"}->{key}!~/^\-/ && $cf->{"$method"}->{"$param"}->{value} ne ''){
		    $tmp.="$cf->{$method}->{$param}->{value}".",";
		}
	        elsif($cf->{"$method"}->{"$param"}->{key} eq "-Return" && $cf->{"$method"}->{"$param"}->{value} ne ''){
		    $tmp="$cf->{$method}->{$param}->{value}".'='.$tmp;
		    last;
	        }
		elsif($cf->{"$method"}->{"$param"}->{key}=~/^\-/ && $cf->{"$method"}->{"$param"}->{value} ne ''){
		    $tmp.="$cf->{$method}->{$param}->{key}"."\=\>".'"'."$cf->{$method}->{$param}->{value}".'",';
		}
	    }
	    chop $tmp;
	    $tmp.=');';
	}
	$script.=$tmp."\n";

    my @args=opt_get(@_);
    my $gcfname=shift @args;

    my $cf;
    my @order;
    my @turn;
    my @code;
    my @tmp;
    my @comment;
    my $g;
    my $i;
    my $u;
    my $t;
    my $switch;
    my $method;

    unless(lstat "$gcfname"){
        &msg_error("GEMS: $gcfname: No such file or directory\n");
        return "HOGE";
    }

    $cf->{GCF}=$gcfname;
    open(GCF,$gcfname);
    while(<GCF>){
	next if($_ eq "\n" || $_ =~ /^\#/);
	$switch++ if(/^1;/);
	$cf->{subroutines}.=$_ if($switch == 4);
	$switch++ if(/^\>User_defined_subroutines/);
	$switch++ if(/^CONFIGURE/);
	$_ =~ tr/\n//d;
	if($switch == 2){
		$u++;
		@comment=split(/#/,$_);
		@code=split(/\s+!order\s+/,$comment[0]);
		$code[1]=~tr/ \n//d;
		$cf->{"User$u"}->{code}=$code[0];
		$cf->{"User$u"}->{order}=$code[1];
		$cf->{"User$u"}->{comment}=$comment[1];
		if($order[$code[1]] ne ''){
		    &msg_error("$code[0]: $order[$code[1]]: Invalid orders!\n");
		    return "HOGE";
		}
		$order[$code[1]]=$code[0] if($code[1] ne '');
		push(@tmp,$code[0]) if($code[1] eq '');	    
	}
	$switch++ if(/>User_defined_functions/);
	if($switch == 1){
	    if(/^(\$\w+)\s*\<\s*(.*)/){
		$g++;
		$cf->{"G$g"}->{instance}=$1;
		$cf->{"G$g"}->{data}=$2;
	    }
	    elsif(/^\>(\w+)/){
		$method=$1;
		$i=1;
	    }
	    elsif(/^\!comment\s*(.*)/){
		$cf->{"$method"}->{comment}=$1;
	    }
	    elsif(/^\!switch\s*(\w*)/){
		$cf->{"$method"}->{switch}='Y' if($1 eq 'Y');
		$cf->{"$method"}->{switch}='N' if($1 ne 'Y');
	    }
	    elsif(/^\!order\s*(\d*)/){
		$cf->{"$method"}->{order}=$1;
		if($cf->{"$method"}->{switch} eq "Y"){
		    if($order[$1] ne ''){
			&msg_error("$method: $order[$1]: Invalid orders!\n");
			return "HOGE";
		    }
		    $order[$1]=$method if($1 ne '');
		    push(@tmp,$method) if($1 eq '');
		}
	    }
	    elsif(/^(\S+)\s*([^\#\s]*)\s*\#*(.*)/){
		if(substr($_,0,1) ne '-' && $2 eq '' && $cf->{"$method"}->{switch} eq "Y"){
		    &msg_error("$method: $1: Lacking parameter input!\n");
		    return "HOGE";
		}
		$cf->{"$method"}->{"param$i"}->{key}=$1;
		$cf->{"$method"}->{"param$i"}->{value}=$2;
		$cf->{"$method"}->{"param$i"}->{comment}=$3;
		$i++;
	    }
	}
	$switch++ if(/\<\< CONFIGURE/);
    }
    close(GCF);
    
    shift @order;
    foreach(@order){
	$turn[$t]=$_ if($_ ne '');
	$turn[$t]=shift(@tmp) if($_ eq '');
	$t++;
    }
    push(@turn,@tmp);
    @{$cf->{Order}}=@turn;

    return $cf;

    my @args=&opt_get(@_);
    
    my $cf=shift @args;
    my $new;
    my $switch;
    my $s_usr;
    my $s_G;
    my $s_p;
    my $method;

    open(GCF,$cf->{GCF});
    while(<GCF>){
	if($switch==0 || $switch==3){
	    $new.=$_;
	    $switch++ if(/\<\< CONFIGURE/);
	    $switch++ if(/\>User_defined_subroutines/);
	    next;
	}
	if(/\>User_defined_functions/){
	    $switch++;
	    $new.=$_;
	    next;
	}
	if(/^CONFIGURE/){
	    $switch++;
	    $new.=$_;
	    next;
	}
	if($switch == 4){
	    $new.="\n".$cf->{subroutines}."\n";
	    last;
	}
	if($_ eq "\n" || $_ =~ /^\#/){
	    $new.=$_;
	    next;
	} 
	if($switch == 2){
	    if($s_usr == 0){
		$s_usr=1;
		foreach(sort keys(%{$cf})){
		    next if($_ !~ /^User/);
		    $new.="$cf->{$_}->{code}\t\!order $cf->{$_}->{order}";
		    $new.="\t\#$cf->{$_}->{comment}\n" if($cf->{$_}->{comment});
		}
	    }
	}
	if($switch == 1){
	    tr/\n//d;
	    if(/(\$\w+)\s*<\s*(.*)/){
		if($s_G == 0){
		    $s_G=1;
		    foreach(sort keys(%{$cf})){
			next if($_ !~ /^G\d+/);
			$new.="$cf->{$_}->{instance}\<  $cf->{$_}->{data}\n";
		    }
		}
	    }
	    elsif(/^\>(\w+)/){
		$new.=$_."\n";
		$method=$1;
		$s_p=0;
	    }
	    elsif(/^(\!comment)\s*.*/){
		$new.=$1."\t".$cf->{"$method"}->{comment}."\n";
	    }
	    elsif(/^(\!switch)\s*\w*/){
		$new.=$1."\t\t".$cf->{"$method"}->{switch}."\n";
	    }
	    elsif(/^(\!order)\s*\d*/){
		$new.=$1."\t\t".$cf->{"$method"}->{order}."\n";
	    }
	    elsif(/^\S+(\s*)[^\#\s]*(\s*)\#*.*/){
		if($s_p == 0){
		    $s_p=1;
		    foreach(sort keys(%{$cf->{"$method"}})){
			next if(substr($_,0,5) ne "param");
			$new.=$cf->{"$method"}->{"$_"}->{key}.$1;
			$new.=$cf->{"$method"}->{"$_"}->{value}.$2;
			$new.="\#".$cf->{"$method"}->{"$_"}->{comment} if($cf->{"$method"}->{"$_"}->{comment});
			$new.="\n";
		    }
		}
	    }
	}
    }
    close(GCF);

    return $new;

    my $pkg = shift;
    my $filename = shift;
    my $option = shift;
    my $this;

    return $this;

General documentation

A. U. Thor, a.u.thor@a.galaxy.far.far.away

perl(1).