001: #!/usr/bin/perl
002: #!/usr/bin/perl -d:ptkdb -w
003: #
004: 
005: 
006: use strict;
007: 
008: 
009: BEGIN
010: {
011:     #! make check
012: 
013:     push @INC, '../perl';
014: 
015:     #! make distcheck
016: 
017:     push @INC, '../../perl';
018: 
019:     #! normal run
020: 
021:     push @INC, './perl';
022: 
023:     #! after install
024: 
025:     push @INC, '/usr/local/glue/swig/perl';
026: 
027:     # check for ".genesis3" directory. If not present we create
028:     # it and set a directory for perl inline code. 
029:     my $inline_path = "$ENV{HOME}/.genesis3/gshell/InlineCode";
030:     if(! -e $inline_path)
031:     {
032:       use File::Path;
033: 
034:       &File::Path::mkpath($inline_path);
035:     }
036: 
037:     $ENV{PERL_INLINE_DIRECTORY} = $inline_path;
038: }
039: 
040: 
041: use Data::Dumper;
042: 
043: use Getopt::Long;
044: 
045: use Term::ReadLine;
046: 
047: use Text::ParseWords;
048: 
049: 
050: $SIG{__DIE__}
051:     = sub {
052:         use Carp;
053: 
054:         confess @_;
055:     };
056: 
057: 
058: #t does not work, I guess because of readline handling it.
059: 
060: $SIG{INT}
061:     = sub {
062:         use Carp;
063: 
064:         confess @_;
065: 
066:         exit 1;
067:     };
068: 
069: 
070: our $option_verbose = 'warnings';
071: 
072: my $option_batch_mode;
073: my $option_execute = [];
074: my $option_output_tags = 0;
075: 
076: my $exit_code = 0;
077: 
078: 
079: sub interprete
080: {
081: 
082:     my $line = shift ;
083: 
084:     $line =~ s/^\s*//;
085: 
086:     my @args = quotewords(" ", 1, $line);
087: 
088:     if($#args == -1)
089:     {
090:       return;
091:     }
092: 
093:     chomp @args;
094: 
095:     my $arguments = \@args;
096: 
097: #    my $arguments = [ split /\s/, $line, ];
098: 
099:     #t join hash and array arguments
100: 
101:     # create a perl function call
102: 
103:     my $quoted_line = $arguments->[0];
104: 
105:     if ($arguments->[1])
106:     {
107:         $quoted_line
108:             .= (
109:                 join
110:                 ' ',
111:                 "(",
112:                 (
113:                  map
114:                  {
115:                      (
116:                       /^('|")/
117:                       ? "$_, "
118:                       : "'$_',"
119:                      )
120:                   }
121:                  (@$arguments)[1 .. $#$arguments]
122:                 ),
123:                 ")"
124:                );
125: 
126:         $quoted_line =~ s/\\n/\n/g;
127:     }
128: 
129:     if ($quoted_line =~ /^\s*(#.*)?$/)
130:     {
131:         return;
132:     }
133: 
134:     # start to prepare to execute of the command
135: 
136:     my $genesis_command;
137: 
138:     {
139:         $genesis_command = $arguments->[0];
140: 
141:         if ($option_output_tags)
142:         {
143:             print "<" .  $genesis_command . ">\n";
144: 
145:             my @args = @$arguments;
146: 
147:             shift @args;
148: 
149:             my $genesis_command_args = join " ", @args;
150: 
151:             print "<args>\n" . $genesis_command_args . "\n</args>\n"
152:         }
153: 
154:         no strict "refs";
155: 
156:         if (!exists ((\%{"::"})->{"GENESIS3::"}->{"Commands::"}->{$genesis_command}))
157:         {
158:             print "*** Error: command $genesis_command not found,\n*** Error: use 'list commands' to get a list of available commands,\n*** Error: use the help function to obtain help about each command\n";
159: 
160:             if ($option_output_tags)
161:             {
162:                 print "</" .  $genesis_command . ">\n";
163:             }
164: 
165:             return;
166:         }
167:     }
168: 
169:     my $package = "GENESIS3::Commands::";
170: 
171:     $quoted_line =~ s/^\s*/$package/;
172: 
173:     my $result = eval($quoted_line);
174: 
175:     if ($@)
176:     {
177:         warn $@;
178: 
179:         print Data::Dumper->Dump( [ $result, ], [ 'Result', ]);
180:     }
181: 
182:     if ($result =~ /^\*\*\* Ok/)
183:     {
184: 
185:     }
186:     else
187:     {
188:         print "$result\n";
189:     }
190: 
191:     if ($option_output_tags)
192:     {
193:         print "</" .  $genesis_command . ">\n";
194:     }
195: }
196: 
197: 
198: sub loop
199: {
200:     my $historyfile = $ENV{HOME} . '/.phistory';
201: 
202:     my $term = Term::ReadLine->new('genesis > ');
203: 
204:     if (open H, $historyfile)
205:     {
206:         my %h;
207: 
208:         my @h = <H>;
209:         chomp @h;
210:         close H;
211: 
212:         $h{$_} = 1 foreach @h;
213:         $term->addhistory($_) foreach keys %h;
214:     }
215: 
216:     if ($option_output_tags)
217:     {
218: 
219:       my $line;
220: 
221:       while(<>){
222: 
223:         $line = $_;
224: 
225:         interprete($line);
226: 
227:         {
228:             open H, ">>$historyfile";
229:             print H "$line\n";
230:             close H;
231:         }
232: 
233:         $term->addhistory($line) if /\S/;
234: 
235:       }
236: 
237:     }
238: 
239: 
240:     while ( defined ($_ = $term->readline("genesis > ")) )
241:     {
242:         my $line = $_;
243: 
244:         interprete($line);
245: 
246:         {
247:             open H, ">>$historyfile";
248:             print H "$line\n";
249:             close H;
250:         }
251: 
252:         $term->addhistory($line) if /\S/;
253:     }
254: }
255: 
256: 
257: 
258: 
259: sub main
260: {
261:     if (!$ENV{NEUROSPACES_NMC_USER_MODELS}
262:         and !$ENV{NEUROSPACES_NMC_PROJECT_MODELS}
263:         and !$ENV{NEUROSPACES_NMC_SYSTEM_MODELS}
264:         and !$ENV{NEUROSPACES_NMC_MODELS})
265:     {
266:         $ENV{NEUROSPACES_NMC_MODELS} = '/usr/local/neurospaces/models/library';
267:     }
268: 
269:     read_cmd_line();
270: 
271:     require GENESIS3;
272: 
273:     GENESIS3::Commands::set_verbose($option_verbose);
274: 
275:     if (!$option_batch_mode)
276:     {
277:         GENESIS3::header();
278:     }
279: 
280:     STDOUT->autoflush(1);
281: 
282:     # process scripts given on the command line
283: 
284:     foreach my $script (@ARGV)
285:     {
286:         use IO::File;
287: 
288:         my $file = IO::File->new("<$script");
289: 
290:         my $lines = [ <$file>, ];
291: 
292:         foreach my $line (@$lines)
293:         {
294:             #t do error processing
295: 
296:             interprete($line);
297:         }
298:     }
299: 
300:     # process --execute arguments
301: 
302:     foreach my $line (@$option_execute)
303:     {
304:         #t do error processing
305: 
306:         interprete($line);
307:     }
308: 
309:     if (!$option_batch_mode)
310:     {
311:         loop();
312:     }
313: }
314: 
315: 
316: sub read_cmd_line
317: {
318:     my $option_help;
319:     my $option_version;
320: 
321:     my $result
322:         = GetOptions
323:             (
324:              "batch-mode!" => \$option_batch_mode,
325:              "execute=s" => $option_execute,
326:              "help!" => \$option_help,
327:              "v|verbose=s" => \$option_verbose,
328:              "version" => \$option_version,
329:              "output-tags" => \$option_output_tags,
330:             );
331: 
332:     if ($option_version)
333:     {
334:         require GENESIS3;
335: 
336:         my $version = GENESIS3::version();
337: 
338:         print $version . "\n";
339: 
340:         exit 1;
341:     }
342: 
343:     if ($option_help)
344:     {
345:         print
346:             "
347: $0 <options>
348: 
349: $0: GENESIS 3 shell.
350: 
351: options:
352:     --batch-mode         batch mode, means that interactive mode is disabled.
353:     --execute            execute this string, may be given multiple times.
354:     --help               print usage information.
355:     --output-tags        Adds XML-like tags to diagnostic messages.
356:     --verbose            set verbosity level ('errors', 'warnings', 'information', 'debug', default is 'warnings').
357:     --version            give version information.
358: 
359: examples:
360: $0 --batch --execute \"echo '---\\n'\" --execute 'list commands'
361: 
362: ";
363: 
364:         exit 0;
365:     }
366: }
367: 
368: 
369: main();
370: 
371: 
372: exit $exit_code;
373: 
374: 
375: