v16.03.2010 (Projekte) - Perl-Community.de

[thread]14702[/thread]

v16.03.2010

Leser: 44

Articles: hide open all | hide show old branches

Teilbäume:
v01.03.2010 (19 Artikel) 2010-03-13 01:42
v09.03.2010 (10 Artikel) 2010-03-15 21:40
v16.03.2010 (18 Artikel) 2010-08-27 00:39

+19 replies

topeg

2010-03-16 01:19

User since
2006-07-10
2611 Artikel
BenutzerIn

user image

haarige Sache. Ich denke der Code hir wird funktionieren, wahrscheinlich aber nicht immer:

Code (perl): (dl )

#!/usr/bin/perl
use strict;
use warnings;

# History:
# conray  - 19.02.2010 : 19:31 UTC - initial version with ping (-ping)
# betterworld - 19.02.2010 : 19:44 UTC - minor changes
# esskar  - 19.02.2010 : 20:27 UTC - changes on ping, and dump myself command (-dump)
# topeg  - 19.02.2010 : 00:02 UTC - addded mirror
# Kalle - 01.03.2010 - added technology assimilation automation
# conray - 02.02.2010 21:07 - added Helpfunktion (-help) and changes on Ping-Parameter
# conray - 03.02.2010 19:28 - added Password-Generator (-pwgen)
# conray - 08.03.2010 21:35 - added print location (-whereami)
# steferbo - 08.03.2010 23:10 - added get country from ip (-get_country)
# topeg - 09.03.2010 23:46 - changed to GetOpt::Long, adapt assimilate ping, pwgen and get_country, added dummy (--dummy), added truemirror (--truemirror <file|->)
# steferbo - 12.03.2010 22:30 - added steuern2010
# topeg - 16.03.2010 01.20 - added echo (--echo <txt>), added export (--export <option>), edit steuern2010, edit assimilate

use Getopt::Long;
use FindBin;
use Net::Ping;
use LWP::UserAgent;
use HTTP::Cookies;
use File::Basename;

# <-- please don't touch this

#EierlegendeWollMilchSau.pl
my %opts=();
my @runn=();
my %commands=();
%commands=(
########################################################################
########################################################################

#_______________________________________________________________________
'dummy' => [
"dummy\t\tDoing nothing!",
sub {
  # empty.
}],
#_______________________________________________________________________
'echo=s,echannel=s,enonewline' => [
"echo <sting> [--echannel <STDOUT|STDERR|file>] [--enonewline]\t\tprint <string> to STDOUT|STDERR|file",
sub {
  my ($txt,$channel,$nnl)=@_;
  $txt='' unless(defined($txt));

  my $fh=\*STDOUT;
  if($channel)
  {
    if($channel eq 'STDERR')
    { $fh=\*STDERR; }
    elsif($channel ne 'STDOUT')
    { open($fh,'>',$channel) or die("ERROR open: $channel ($!)\n"); }
  }

  print $fh $txt,$nnl?'':"\n";
}],

#_______________________________________________________________________
'help|h' => [
"help\t\tprint out this usagetext",
sub{
  HELP();
},
'runn now'],

#_______________________________________________________________________
'ping=s,range=i' => [
"ping <ip> [--range=<range>]\t\ttrys to ping an ip or an range of ip addresses.",
sub
{
  my ($ip,$till) = @_;
  my @r = split(/\./, $ip);

  $till=$r[3] unless(defined($till));

  my $until = $till + 1;
  while ($r[3] < $until )
  {
    $ip = join '.', @r;
    my $ping = Net::Ping->new('icmp', 1, 64 );
    print "$ip " . ($ping->ping($ip) ? 'online' : 'offline') . "\n";
    $r[3]++;
  }
}],

#_______________________________________________________________________
'dump' => [
"dump\t\tdumps itself to STDOUT",
sub
{
  my $path = "$FindBin::Bin/$FindBin::Script";
  open(my $myself, "< $path") or die "Unable to open myself ($path): $!";
  while(<$myself>) { print $_; }
  close $myself;
}],

#_______________________________________________________________________
'devil' => [
"devil\t\tDon't try that",
sub
{
  print "So long, and thanks for all the fish.\n";
  unlink $0 or die "Will not stop :'-(\n";
}],

#_______________________________________________________________________
'mirror=s' => [
"mirror <file|->\t\tmirror file or STDIN",
sub
{
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  chomp($_) && print reverse($_)."\n" while(<$fh>);
  close($fh);
}],

#_______________________________________________________________________
'truemirror=s' => [
"truemirror <file|->\t\tmirror file or STDIN",
sub
{
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  my @lines=();
  my $length;
  while (my $line=<$fh>)
  {
    $length=length($line) if(!defined($length) || $length<length($line));
    chomp($line);
    $line=reverse($line);
    $line=~y/()[]{}\\\/`´<>/)(][}{\/\\´`></;
    push(@lines,$line);
  }
  printf ("%${length}s\n",$_) for(@lines);
  close($fh);
}],

#_______________________________________________________________________
'assimilate=s,asshelptext=s' => [
"assimilate newparam.pl [--asshelptext <helptext>]\t\tassimilate more perl code into this script",
sub
{
  my $newtechsource=shift;
  my $helptext=shift || "assimilated weird stuff";
  my $borgtechnology;
  my $assimilationspace;
  my $newtechnology;
  my ($newcmdname)=split(/\./,$newtechsource,0);
  $newcmdname=~y/=|!?//d;
  $newcmdname=~s/\s+/_/s;
  my ($borgbase,$borgpath)=fileparse($0);
  my $newborgtechnology="${borgpath}Neue$borgbase";
  if (open($borgtechnology,'<',$0)) {
    if (open($assimilationspace,'>',$newborgtechnology)) {
      if (open($newtechnology,'<',$newtechsource)) {
        while(<$borgtechnology>) {
          if (/^# <-- don't touch this/) {
             my $thisline=$_;
             print "Assimiliere neue Technologie...\n";
             print $assimilationspace qq!
#_______________________________________________________________________
'$newcmdname' => [
"$newcmdname\\t\\t $helptext",
sub {
!;
             while(<$newtechnology>) {
               next if (/^#!|^use strict;|^use warnings;/);
               print $assimilationspace $_;
             }
             close($newtechnology);
             print $assimilationspace qq!
},
'runn now'],

$thisline!;
          }
          else {
            print $assimilationspace $_;
          }
        }
        close($borgtechnology);
        if (close($assimilationspace)) {
          print "Widerstand war zwecklos!\nNeue Technologie einsetzbar: Neue$borgbase --$newcmdname\n";
        }
        else {
          print "Aktivierungssequenz ungültig. Assimilation abgebrochen.\n";
        }
      }
      else {
        print "Neue Technologie kann nicht assimiliert werden. Abbruch der Assimilation\n";
      }
    }
    else {
      print "Fluktuation im temporären Raum-/Zeitgefüge. Abbruch der Assimilation.\n";
    }
  }
  else {
    print "Wo sind wir ? Es ist so....leise. Bring uns nach Hause!\n";
  }
}],

#_______________________________________________________________________
'pwgen=i' => [
"pwgen\t\tgenerates an (secure) password",
sub
{
  my $input=shift;
  unless($input)
  {
    print "How much positions your password should have?\n";
    print "Note: Secure passwords have 10 positions as minimum \n";
    $input=<STDIN>;
    chomp $input;
  }
  $input=~s/[^\-\d].+$//;
  $input=abs($input);

  my @bletters = ("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z");
  my @sletters = ("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z");
  my @numbers = ("1", "2", "3", "4", "5", "6", "7", "8", "9", "0");
  my @special = ("!", "\.", "\$", "\%", "\&", "?", "\/", "\\", "\,", "-", "_", "\#", "\*", ":", "(", ")", "=", "+", "<", "§", "[", "]", "\;");

  my $pw='';
  while (length($pw) != $input) {
     my $n1 = int(rand(26));
     my $n2 = int(rand(26));
     my $n3 = int(rand(10));
     my $n4 = int(rand(23));
     my $z = int(rand(4));
     if ($z == 0) {
        $pw = $pw . $bletters[$n1]; }
     elsif ($z == 1) {
        $pw = $pw . $sletters[$n2]; }
     elsif ($z == 2) {
        $pw = $pw . $numbers[$n3]; }
     elsif ($z == 3) {
        $pw = $pw . $special[$n4]; }
     else {
        print "There is bug";
        exit; }
     }
  print "The generated Password is: $pw \n";
}],

#_______________________________________________________________________
'whereami' => [
"whereami\t\tprint out the filelocation",
sub
{
  print __FILE__."\n";
}],

#_______________________________________________________________________
'get_country=s' => [
"get_country <ip>\t\tsingle-host 32bit decimal",
sub
{
  my $ip = shift;
  my $line=""; my $country=""; my $out="IP: $ip is non-registered";
  my $whois="http://www.utrace.de/whois/";
  my $hol=$whois.$ip;
  my $html=stuff($hol);
    $html =~ s/<([^>]|\n)*>//mig;
    $html =~ s/&nbsp;//mig;
    (my @text)=split(/\n/,$html);
        foreach $line (@text){
                      if( $line =~ /country:/ig ){
                      $line =~ s/\s//ig;
      (my $nix, $country)=split(/:/,$line);
                      $out="IP: $ip has country-code: $country";
                      goto ELMS;
          } # end if
         } # end foeach
  ELMS:
  print $out;
}],


#_______________________________________________________________________
'steuer2010=s' => [
"steuer2010 <einkommen>\t\tSteuer2010 - ESt und SolZ ",
sub
{
my $x=shift;

unless(defined($x))
{
  print "\n\nzu versteuerndes Einkommen: ";
  chomp ($x = <STDIN>);
}

my $est=0;my $soli=0;my $estsplit=0; my $solisplit=0;
if($x > 8004 && $x < 13470){$est=int((912.17*($x -8004)/10000+1400)*($x- 8004)/10000);}
if($x > 13469 && $x < 52882){$est=int((228.74*($x -13469)/10000+2397)*($x-13469)/10000+1038);}
if($x > 52881 && $x < 250731){$est=int($x*0.42-8172);}
if($x > 250730){$est=int($x*0.45-15694);}

my $xx=$x/2;
if($xx > 8004 && $xx < 13470){$estsplit=int((912.17*($xx -8004)/10000+1400)*($xx- 8004)/10000)*2;}
if($xx > 13469 && $xx < 52882){$estsplit=int((228.74*($xx -13469)/10000+2397)*($xx-13469)/10000+1038)*2;}
if($xx > 52881 && $xx < 250731){$estsplit=int($xx*0.42-8172)*2;}
if($xx > 250730){$estsplit=int($xx*0.45-15694)*2;}

if($est > 972){$soli=int($est*0.055);}
if($estsplit >1944){
     $solisplit=int($estsplit*0.055); my $test= int(($estsplit-1944)*0.2);
       if ($solisplit > $test){$solisplit=$test;}
  }
my $netto=$x-$est-$soli; my $nettosplit=$x-$estsplit-$solisplit;

print"\n             \t   - (ohne Kirche/Kind)  Steuer 2010 -    \n\n";
print"                         \tGrundtarif \t Splitting \n\n";
print"                    ESt: \t$est       \t $estsplit  \n\n";
print"     (* Vorbehalt) SolZ: \t$soli      \t $solisplit \n\n";
print"                  ----------------------------------------- \n";
print"                  Netto: \t$netto     \t $nettosplit \n";
print"\n\n * if(Verfassungsgericht_Urteil eq \"widerrechtlich\") {automatische Erstattung}\n\n";
}],

#_______________________________________________________________________
'export=s,expopts=s' => [
"export <optionname> [--expopts '<B::Deparse Options>']\t\texport one option of this script",
sub {
  my ($option)=shift || '';
  my $depopts=shift || '';
  my @opts=split(/\s+/,$depopts);

  # normiere options_name
  $option=~s/^\-+//;
  $option=~s/=.*$//;
  $option=~s/\s.*$//;
  $option=~s/^\s+//;

  # finde hash_name zur Option
  my $name='';
  for my $key (keys(%commands))
  {
    if($key=~m!(?:^|,)\Q$option\E(?:=|,|$)!)
    {
      $name=$key;
      last;
    }
  }

  unless($name)
  {
    warn("NO valid Option: $option\n");
    HELP();
    return;
  }


  # code und hilfe holen
  my $cref=$commands{$name}->[1];
  my $help=$commands{$name}->[0];
  $help=~s/\t\t/\\n\\t/;

  # codereferenz in text umwandeln
  use B::Deparse;
  my $code = B::Deparse->new(@opts)->coderef2text($cref);

  # script lesen
  my $code_else='';
  {
    my $pos=tell(DATA);
    seek(DATA,0,0);
    local $/=undef;
    $code_else=<DATA>;
    seek(DATA,$pos,0);
  }

  # Optionen umwandeln
  my @opt_list=split(/\s*,\s*/,$name);
  my @ref_list=();
  my $first=shift(@opt_list);
  if($first=~/=/)
  { $first='unshift(@opts,shift(@ARGV));'; }
  else
  { $first='unshift(@opts,1);'; }
  for(0..$#opt_list)
  {
    $opt_list[$_] =qq('$opt_list[$_]').' => \$opts['.($_+1).']';
    push(@ref_list,'undef');
  }
  push(@opt_list,q('help' => sub{ HELP(); }));

  # startcode erzeugen
  my $scode=sprintf(<<'EOC',join(', ',@ref_list),join(", ",@opt_list),$first,$option,$help,$option,$code);
my @opts=(%s);

my $ok=GetOptions(%s);

%s

HELP() if(@ARGV);
HELP() unless($ok);

%s(@opts);

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub HELP
{
  print "usage: %s\n";
  exit(0);
}

sub %s
%s

EOC
  # history ändern
  my $time=localtime();
  $code_else=~s!# History:(?:\n#[^\n]+)*!# History:\n# AUTOEXPORT - $time - export of $option\n!;
  # code einfügen
  # von <-- please don't touch this
  # bis # FUNCTIONS #
  # wird alles gelöscht
  $code_else=~s!# <-- please don't touch this.+\n#+\n# FUNCTIONS #+\n#+\n!$scode!s;
  # unwichtige Funktionen entfernen
  $code_else=~s!#+\n# BUILD IN FUNCTIONS #+\n#+\n.+$!__END__!s;

  # alles in Datei schreiben
  open(my $fh, '>', "$option.pl") or die "ERROR open $option.pl ($!)";
  print $fh $code_else;
  close($fh);
}],

# <-- don't touch this

########################################################################
########################################################################
);

for(keys(%commands))
{
  my $opt=$_;
  my $cmdref=$commands{$_}[1];
  my $runn_mod='runn last';
  $runn_mod=lc($commands{$_}[2]) if(exists($commands{$_}[2]));
  my @olist=split(/\s*,\s*/s,$opt);

  if($runn_mod eq 'runn now')
  {
    for(@olist)
    { $opts{$_}=sub{ $cmdref->(pop(@_)); } }
  }
  elsif($runn_mod eq 'runn first')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,1); }
    }
  }
  elsif($runn_mod eq 'runn last')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,0); }
    }
  }
  else
  { die(qq#Can't interpret runn modifier "$runn_mod" \n#); }
}
my $ok=GetOptions(%opts);

HELP(@ARGV) if(@ARGV);
HELP(0) unless($ok);

for my $cmd (@runn)
{
  my $name=shift(@$cmd);
  $commands{$name}->[1]->(@$cmd);
}

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub stuff {
  my $url=shift;
  my $agent="Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.9.0.18) EierlegendeMilchSau/1.0.0";
  my $cookie = HTTP::Cookies->new;

  my $req = HTTP::Request->new(GET => $url);
  $req->header('Referer', '');
  $req->header('Accept', 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8');
  $req->header('Accept-Language', 'de-de,de;q=0.8,en-us;q=0.5,en;q=0.3');
  $req->header('Accept-Charset', 'ISO-8859-1,utf-8;q=0.7,*;q=0.7');
  $req->header('Keep-Alive', '115');
  $req->header('Cache-Control', 'max-age=0');
  my $browser = LWP::UserAgent->new;
  $browser -> agent($agent);
  $browser -> cookie_jar($cookie);
  my $res = $browser->request($req);
  my $stuff = $res->content;
  return ($stuff);
}# end sub stuff

########################################################################
# BUILD IN FUNCTIONS ###################################################
########################################################################

sub add_cmd
{
  my $name=shift;
  my $opt=shift;
  my $pos=shift || 0;
  my $first=shift || 0;
  for my $ref (@runn)
  {
    if($ref->[0] eq  $name)
    {
      $ref->[$pos+1]=$opt;
      return;
    }
  }

  if($first)
  { unshift(@runn,[$name,$opt]); }
  else
  { push(@runn,[$name,$opt]); }
}

sub HELP{
  my @errors=@_;

  my @list=();
  my $length_first;
  my $length_second;
  for my $cmd (sort keys(%commands))
  {
    $length_first=length($cmd) if(!defined($length_first) || $length_first<length($cmd));
    my ($cmdtxt,$desctxt)=split("\t\t",$commands{$cmd}->[0],2);
    $desctxt='' unless($desctxt);
    $cmdtxt='' unless($cmdtxt);
    $length_second=length($cmdtxt) if(!defined($length_second) || $length_second<length($cmdtxt));
    push(@list,[$cmd,$cmdtxt,$desctxt]);
  }

  my $oh=\*STDOUT;
  $oh=\*STDERR if @errors;

  if($errors[0])
  {
    for(@errors)
    { print $oh "Unknown option: $_\n"; }
  }

  print $oh "usage: $0 <parameters>\n\n";
  print $oh "parameters:\n";

  for(@list)
  { printf $oh "  %-${length_first}s => --%-${length_second}s %s\n", @$_; }

  print $oh "\n";
  exit(@errors?1:0);
}

__END__

Das Problem ist, dass man nicht genau wissen kann wie der Code aussieht und auf was er zugreift. So kann man "export" mittels "--export" nicht vernünftig exportieren :-) auch "assimilate" lässt sich nicht funktionstüchtig exportieren. Alle anderen "sollten" sich exportieren lassen, habe ich aber nicht getestet.
Last edited: 2010-03-16 12:02:43 +0100 (CET)

+10 replies

conray

2010-03-16 11:29

User since
2010-02-19
52 Artikel
BenutzerIn
[default_avatar]

nice.
Habs grad mal probiert. Egal was ich exportiere der sub stuff vom get_country kommt immer mit hitnerher. Soll das so sein?

Meine Frage ob mal eine for-Schleife eingrenzen kann mit Markern oder so besteht weiterhin :)

mfg
conray

renee

2010-03-16 11:38

User since
2003-08-04
14371 Artikel
ModeratorIn

Du könntest mit dem Flip-Flop-Operator arbeiten. Siehe http://reneeb-perlblog.blogspot.com/2010/01/der-fl...
OTRS-Erweiterungen (http://feature-addons.de/)
Frankfurt Perlmongers (http://frankfurt.pm/)
--

Unterlagen OTRS-Workshop 2012: http://otrs.perl-services.de/workshop.html
Perl-Entwicklung: http://perl-services.de/
+8 replies

topeg

2010-03-16 11:54

User since
2006-07-10
2611 Artikel
BenutzerIn

user image

2010-03-16T10:29:42 conray
Habs grad mal probiert. Egal was ich exportiere der sub stuff vom get_country kommt immer mit hitnerher. Soll das so sein?

Ja, du kannst lesen, dass die Funktion "stuff" zu "get_country" gehört, ich müsste den kompletten PerlCode parsen und interpretieren, daran sind schon ganz andere gescheitert. Der Code kann nicht wissen von wo die Funktionen zwischen "FUNCTIONS" und "BUILD IN FUNCTIONS" aufgerufen werden. Genauso wie der Code nicht erraten kann welche "use" Statements gebraucht werden.

2010-03-16T10:29:42 conray
Meine Frage ob mal eine for-Schleife eingrenzen kann mit Markern oder so besteht weiterhin :)

Meinst du die Fage?

conray
Wie kann ich die for schleife auf einen bestimmten Teil des Sciptes lenken?
kann man Marker setzen? Oder es an den subs festmachen?

Ich habe echte Probleme zu verstehen was du meinst.

willst du andere subs aus %commands ausführen? willst du goto verwenden? Was willst du?

Gundsätzlich:
Wenn du vorhanden Code nutzen willst musst du ihn in eine Funktion tun und zwischen "FUNCTIONS" und "BUILD IN FUNCTIONS" stellen. (wie "stuff" auch) Ansonsten würde er mittels "export" nicht mit kopiert.
Es wäre möglich andere "subs" aufzurufen, aber nicht zu empfehlen, das würde "export" unbrauchbar machen.

+7 replies

conray

2010-03-16 13:16

User since
2010-02-19
52 Artikel
BenutzerIn
[default_avatar]

Nein ich mein das so:
zb: Ping exportieren.
-Marker1-
code
-Marker2-

' for $i in __FILE__ ' zb soll jetzt nur vom -Marker1- bis -Marker2- funktionieren. (also eingrenzen)

Aebr diese Marker sind in diesem Falle wohl
"FUNCTIONS" nd "BUILD IN FUNCTIONS".
Aber mal generell wie kann man eine Schleife so lenken das sie nur den vordefinierten bereich durchläuft?

mfg
conray

+6 replies

topeg

2010-03-16 13:29

User since
2006-07-10
2611 Artikel
BenutzerIn

user image

Schau mal im post von renee:

Code (perl): (dl )

while( my $line = <__FILE__> )
{
  if $line =~ /^\Q-Marker1-\E/ .. $line =~ /^\Q-Marker2-\E/
  {
    # mach was mit $line
  }
}

Ich mache es etwas anders, da ich nur ersetzen möchte und nicht irgendwie verarbeiten:

Code (perl): (dl )

local $/=undef;
my $alles=<__FILE__>;

my $ersetzung="....";

$alles=~s/\Q-Marker1-\E.+\Q-Marker2-\E/$ersetzung/;

# ....

+5 replies

conray

2010-03-16 20:32

User since
2010-02-19
52 Artikel
BenutzerIn
[default_avatar]

Code (perl): (dl )

#!/usr/bin/perl
use strict;
use warnings;

# History:
# conray  - 19.02.2010 : 19:31 UTC - initial version with ping (-ping)
# betterworld - 19.02.2010 : 19:44 UTC - minor changes
# esskar  - 19.02.2010 : 20:27 UTC - changes on ping, and dump myself command (-dump)
# topeg  - 19.02.2010 : 00:02 UTC - addded mirror
# Kalle - 01.03.2010 - added technology assimilation automation
# conray - 02.02.2010 21:07 - added Helpfunktion (-help) and changes on Ping-Parameter
# conray - 03.02.2010 19:28 - added Password-Generator (-pwgen)
# conray - 08.03.2010 21:35 - added print location (-whereami)
# steferbo - 08.03.2010 23:10 - added get country from ip (-get_country)
# topeg - 09.03.2010 23:46 - changed to GetOpt::Long, adapt assimilate ping, pwgen and get_country, added dummy (--dummy), added truemirror (--truemirror <file|->)
# steferbo - 12.03.2010 22:30 - added steuern2010

use Getopt::Long;

use FindBin;
use Net::Ping;
use LWP::UserAgent;
use HTTP::Cookies;
use File::Basename;

#EierlegendeWollMilchSau.pl
my %opts=();
my @runn=();
my %commands=(
########################################################################
########################################################################
#_______________________________________________________________________
'dummy' => [
"dummy\t\tDoing nothing!",
sub {
  # empty.
}],

#_______________________________________________________________________
'help|h' => [
"help\t\tprint out this usagetext",
sub{
  HELP();
},
'runn now'],

#_______________________________________________________________________
'ping=s,range=i' => [
"ping <ip> [--range=<range>]\t\ttrys to ping an ip or an range of ip addresses.",
sub
{
  #exmark-ping-start
  my ($ip,$till) = @_;
  my @r = split(/\./, $ip);

  $till=$r[3] unless(defined($till));

  my $until = $till + 1;
  while ($r[3] < $until )
  {
    $ip = join '.', @r;
    my $ping = Net::Ping->new('icmp', 1, 64 );
    print "$ip " . ($ping->ping($ip) ? 'online' : 'offline') . "\n";
    $r[3]++;
  }
  #exmark-ping-stop
}],

#_______________________________________________________________________
'dump' => [
"dump\t\tdumps itself to STDOUT",
sub
{
  #exmark-dump-start
  my $path = "$FindBin::Bin/$FindBin::Script";
  open(my $myself, "< $path") or die "Unable to open myself ($path): $!";
  while(<$myself>) { print $_; }
  close $myself;
  #exmark-dump-stop
}],

#_______________________________________________________________________
'devil' => [
"devil\t\tDon't try that",
sub
{
  #exmark-devil-start
  print "So long, and thanks for all the fish.\n";
  unlink $0 or die "Will not stop :'-(\n";
  #exmark-devil-stop
}],

#_______________________________________________________________________
'mirror=s' => [
"mirror <file|->\t\tmirror file or STDIN",
sub
{
  #exmark-mirror-start
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  chomp($_) && print reverse($_)."\n" while(<$fh>);
  close($fh);
  #exmark-mirror-stop
}],

#_______________________________________________________________________
'truemirror=s' => [
"truemirror <file|->\t\tmirror file or STDIN",
sub
{
  #exmark-truemirror-start
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  my @lines=();
  my $length;
  while (my $line=<$fh>)
  {
    $length=length($line) if(!defined($length) || $length<length($line));
    chomp($line);
    $line=reverse($line);
    $line=~y/()[]{}\\\/`´<>/)(][}{\/\\´`></;
    push(@lines,$line);
  }
  printf ("%${length}s\n",$_) for(@lines);
  close($fh);
  #exmark-truemirror-stop
}],

#_______________________________________________________________________
'assimilate=s' => [
"assimilate newparam.pl\t\tassimilate more perl code into this script",
sub
{
  #exmark-assimilate-start
  my $newtechsource=shift;
  my $borgtechnology;
  my $assimilationspace;
  my $newtechnology;
  my ($newcmdname)=split(/\./,$newtechsource,0);
  $newcmdname=~y/=|!?//d;
  $newcmdname=~s/\s+/_/s;
  my ($borgbase,$borgpath)=fileparse($0);
  my $newborgtechnology="${borgpath}Neue$borgbase";
  if (open($borgtechnology,'<',$0)) {
    if (open($assimilationspace,'>',$newborgtechnology)) {
      if (open($newtechnology,'<',$newtechsource)) {
        while(<$borgtechnology>) {
          if (/^# <-- don't touch this/) {
             my $thisline=$_;
             print "Assimiliere neue Technologie...\n";
             print $assimilationspace qq!
#exmark-assimilate-stop
#_______________________________________________________________________
'$newcmdname' => [
"$newcmdname\\t\\t assimilated weird stuff",
sub {
#exmark-assimilate-part-start
!;
             while(<$newtechnology>) {
               next if (/^#!|^use strict;|^use warnings;/);
               print $assimilationspace $_;
             }
             close($newtechnology);
             print $assimilationspace qq!
},
'runn now'],

$thisline!;
          }
          else {
            print $assimilationspace $_;
          }
        }
        close($borgtechnology);
        if (close($assimilationspace)) {
          print "Widerstand war zwecklos!\nNeue Technologie einsetzbar: Neue$borgbase --$newcmdname\n";
        }
        else {
          print "Aktivierungssequenz ungültig. Assimilation abgebrochen.\n";
        }
      }
      else {
        print "Neue Technologie kann nicht assimiliert werden. Abbruch der Assimilation\n";
      }
    }
    else {
      print "Fluktuation im temporären Raum-/Zeitgefüge. Abbruch der Assimilation.\n";
    }
  }
  else {
    print "Wo sind wir ? Es ist so....leise. Bring uns nach Hause!\n";
  }
  #exmark-assimilate-part-stop
}],

#_______________________________________________________________________
'pwgen=i' => [
"pwgen\t\tgenerates an (secure) password",
sub
{
  #exmark-pwgen-start
  my $input=shift;
  unless($input)
  {
    print "How much positions your password should have?\n";
    print "Note: Secure passwords have 10 positions as minimum \n";
    $input=<STDIN>;
    chomp $input;
  }
  $input=~s/[^\-\d].+$//;
  $input=abs($input);

  my @bletters = ("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z");
  my @sletters = ("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z");
  my @numbers = ("1", "2", "3", "4", "5", "6", "7", "8", "9", "0");
  my @special = ("!", "\.", "\$", "\%", "\&", "?", "\/", "\\", "\,", "-", "_", "\#", "\*", ":", "(", ")", "=", "+", "<", "§", "[", "]", "\;");

  my $pw='';
  while (length($pw) != $input) {
     my $n1 = int(rand(26));
     my $n2 = int(rand(26));
     my $n3 = int(rand(10));
     my $n4 = int(rand(23));
     my $z = int(rand(4));
     if ($z == 0) {
        $pw = $pw . $bletters[$n1]; }
     elsif ($z == 1) {
        $pw = $pw . $sletters[$n2]; }
     elsif ($z == 2) {
        $pw = $pw . $numbers[$n3]; }
     elsif ($z == 3) {
        $pw = $pw . $special[$n4]; }
     else {
        print "There is bug";
        exit; }
     }
  print "The generated Password is: $pw \n";
  #exmark-pwgen-stop
}],

#_______________________________________________________________________
'whereami' => [
"whereami\t\tprint out the filelocation",
sub
{
  #exmark-whereami-start
  print __FILE__."\n";
  #exmark--whereami-stop
}],

#_______________________________________________________________________
'get_country=s' => [
"get_country <ip>\t\tsingle-host 32bit decimal",
sub
{
  #exmark-get_country-start
  my $ip = shift;
  my $line=""; my $country=""; my $out="IP: $ip is non-registered";
  my $whois="http://www.utrace.de/whois/";
  my $hol=$whois.$ip;
  my $html=stuff($hol);
    $html =~ s/<([^>]|\n)*>//mig;
    $html =~ s/&nbsp;//mig;
    (my @text)=split(/\n/,$html);
        foreach $line (@text){
                      if( $line =~ /country:/ig ){
                      $line =~ s/\s//ig;
      (my $nix, $country)=split(/:/,$line);
                      $out="IP: $ip has country-code: $country";
                      goto ELMS;
          } # end if
         } # end foeach
  ELMS:
  print $out;
  #exmark-get_country-stop
}],

#_______________________________________________________________________
'export=s, filename=i' => [
"export parameter [--file=<filename>]\t\texports a part of this script into a standalonescript",
sub
{
  my ($com, $file) = @_;
  my $line;
  
  open (out, ">> $file");
  print out '#!/usr/bin/perl';
  print out 'use strict;';
  print out 'use warnings;';
  print out 'use FindBin;';
  print out 'use Net::Ping;';
  print out 'use LWP::UserAgent;';
  print out 'use HTTP::Cookies;';
  print out 'use File::Basename;';
  close out;
  
  if ($com == "assimilate" || $com == "get_country")
  
  {
    while($line = <__FILE__> )
    {
      if ($line =~ /^\Q\#exmark-$com-start\E/ .. $line =~ /^\Q\#exmark-$com-start\E/)
      {
        open (out, ">> $file");
        print out $line;
        close out;
      }
      if ($line =~ /^\Q\#exmark-$com-part-start\E/ .. $line =~ /^\Q\#exmark-$com-part-start\E/)
      {
        open (out, ">> $file");
        print out $line;
        close out;
      }
    }
  }
  else {
    while($line = <__FILE__> )
      {
        if ($line =~ /^\Q\#exmark-$com-start\E/ .. $line =~ /^\Q\#exmark-$com-start\E/)
        {
          open (out, ">> $file");
          print out '#!/usr/bin/perl';
          print out $line;
          close out;
        }
      }
    }
}],

#_______________________________________________________________________
'steuer2010' => [
"steuer2010\t\tSteuer2010 - ESt und SolZ ",
sub
{
#exmark-steuer2010-start
print "\n\nzu versteuerndes Einkommen: "; chomp (my $x = <STDIN>);
my $est=0;my $soli=0;my $estsplit=0; my $solisplit=0;
if($x > 8004 && $x < 13470){$est=int((912.17*($x -8004)/10000+1400)*($x- 8004)/10000);}
if($x > 13469 && $x < 52882){$est=int((228.74*($x -13469)/10000+2397)*($x-13469)/10000+1038);}
if($x > 52881 && $x < 250731){$est=int($x*0.42-8172);}
if($x > 250730){$est=int($x*0.45-15694);}

my $xx=$x/2;
if($xx > 8004 && $xx < 13470){$estsplit=int((912.17*($xx -8004)/10000+1400)*($xx- 8004)/10000)*2;}
if($xx > 13469 && $xx < 52882){$estsplit=int((228.74*($xx -13469)/10000+2397)*($xx-13469)/10000+1038)*2;}
if($xx > 52881 && $xx < 250731){$estsplit=int($xx*0.42-8172)*2;}
if($xx > 250730){$estsplit=int($xx*0.45-15694)*2;}

if($est > 972){$soli=int($est*0.055);}
if($estsplit >1944){
     $solisplit=int($estsplit*0.055); my $test= int(($estsplit-1944)*0.2);
       if ($solisplit > $test){$solisplit=$test;}
  }
my $netto=$x-$est-$soli; my $nettosplit=$x-$estsplit-$solisplit;

print"\n             \t   - (ohne Kirche/Kind)  Steuer 2010 -    \n\n";
print"                         \tGrundtarif \t Splitting \n\n";
print"                    ESt: \t$est       \t $estsplit  \n\n";
print"     (* Vorbehalt) SolZ: \t$soli      \t $solisplit \n\n";
print"                  ----------------------------------------- \n";
print"                  Netto: \t$netto     \t $nettosplit \n";
print"\n\n * if(Verfassungsgericht_Urteil eq \"widerrechtlich\") {automatische Erstattung}\n\n";
#exmark-steuer2010-stop
},
'runn now'],

# <-- don't touch this

########################################################################
########################################################################
);

for(keys(%commands))
{
  my $opt=$_;
  my $cmdref=$commands{$_}[1];
  my $runn_mod='runn last';
  $runn_mod=lc($commands{$_}[2]) if(exists($commands{$_}[2]));
  my @olist=split(/\s*,\s*/s,$opt);

  if($runn_mod eq 'runn now')
  {
    for(@olist)
    { $opts{$_}=sub{ $cmdref->(pop(@_)); } }
  }
  elsif($runn_mod eq 'runn first')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,1); }
    }
  }
  elsif($runn_mod eq 'runn last')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,0); }
    }
  }
  else
  { die(qq#Can't interpret runn modifier "$runn_mod" \n#); }
}
my $ok=GetOptions(%opts);

HELP(@ARGV) if(@ARGV);
HELP(0) unless($ok);

for my $cmd (@runn)
{
  my $name=shift(@$cmd);
  $commands{$name}->[1]->(@$cmd);
}

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub stuff {
  #exmark-get_country-part-start
  my $url=shift;
  my $agent="Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.9.0.18) EierlegendeMilchSau/1.0.0";
  my $cookie = HTTP::Cookies->new;

  my $req = HTTP::Request->new(GET => $url);
  $req->header('Referer', '');
  $req->header('Accept', 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8');
  $req->header('Accept-Language', 'de-de,de;q=0.8,en-us;q=0.5,en;q=0.3');
  $req->header('Accept-Charset', 'ISO-8859-1,utf-8;q=0.7,*;q=0.7');
  $req->header('Keep-Alive', '115');
  $req->header('Cache-Control', 'max-age=0');
  my $browser = LWP::UserAgent->new;
  $browser -> agent($agent);
  $browser -> cookie_jar($cookie);
  my $res = $browser->request($req);
  my $stuff = $res->content;
  return ($stuff);
  #exmark-get_country-part-stop
}# end sub stuff


sub add_cmd
{
  my $name=shift;
  my $opt=shift;
  my $pos=shift || 0;
  my $first=shift || 0;
  for my $ref (@runn)
  {
    if($ref->[0] eq  $name)
    {
      $ref->[$pos+1]=$opt;
      return;
    }
  }

  if($first)
  { unshift(@runn,[$name,$opt]); }
  else
  { push(@runn,[$name,$opt]); }
}

sub HELP{
  my @errors=@_;

  my @list=();
  my $length_first;
  my $length_second;
  for my $cmd (sort keys(%commands))
  {
    $length_first=length($cmd) if(!defined($length_first) || $length_first<length($cmd));
    my ($cmdtxt,$desctxt)=split("\t\t",$commands{$cmd}->[0],2);
    $desctxt='' unless($desctxt);
    $cmdtxt='' unless($cmdtxt);
    $length_second=length($cmdtxt) if(!defined($length_second) || $length_second<length($cmdtxt));
    push(@list,[$cmd,$cmdtxt,$desctxt]);
  }

  my $oh=\*STDOUT;
  $oh=\*STDERR if @errors;

  if($errors[0])
  {
    for(@errors)
    { print $oh "Unknown option: $_\n"; }
  }

  print $oh "usage: $0 <parameters>\n\n";
  print $oh "parameters:\n";

  for(@list)
  { printf $oh "  %-${length_first}s => --%-${length_second}s %s\n", @$_; }

  print $oh "\n";
  exit(@errors?1:0);
}

__END__

Habe auch mal versuch nen export zu schreiben.
Wenn es so funktioneiren würde wie ich es mir denk dann
ich bekomm aber immer errors.
einmal wegen dem string "out" und einemal weil die parameterübernahme wohl noch nicht ganz glatt läuft.

hier die meldung:

Quote
Unquoted string "out" may clash with future reserved word at alles.pl line 295.
Unquoted string "out" may clash with future reserved word at alles.pl line 296.
Unquoted string "out" may clash with future reserved word at alles.pl line 297.
Unquoted string "out" may clash with future reserved word at alles.pl line 301.
Unquoted string "out" may clash with future reserved word at alles.pl line 302.
Unquoted string "out" may clash with future reserved word at alles.pl line 303.
Unquoted string "out" may clash with future reserved word at alles.pl line 312.
Unquoted string "out" may clash with future reserved word at alles.pl line 313.
Unquoted string "out" may clash with future reserved word at alles.pl line 314.
Unknown option: pin.pl
usage: alles.pl <parameters>
.....

Habt ihr eine Idee?

+2 replies

Linuxer

2010-03-16 20:58

User since
2006-01-27
3870 Artikel
HausmeisterIn

user image

Hi,

zu den "out"-Warnungen (keine Fehler):

Du solltest besser lexikalische Filehandles benutzen und auch die 3-Argument-Form des open:

Code: (dl )

open my $handle, '>>', $filename or die "$filename: $!\n";

print $handle @your_data;

close $handle or die "$filename: $!\n";

Siehe auch:
Wiki:

WasIsteinLexikalischerFileHandle

meine Beiträge: I.d.R. alle Angaben ohne Gewähr und auf Linux abgestimmt!
Die Sprache heisst Perl, nicht PERL. - Bitte Crossposts als solche kenntlich machen!

conray

2010-03-16 21:40

User since
2010-02-19
52 Artikel
BenutzerIn
[default_avatar]

Code (perl): (dl )

#_______________________________________________________________________
'export=s, filename=i' => [
"export parameter [--file=<filename>]\t\texports a part of this script into a standalonescript",
sub
{
  my ($com, $file) = @_;
  my $line;
  
  open my $handle, '>>', $file or die "$file: $!\n";
  print $handle '#!/usr/bin/perl';
  print $handle 'use strict;';
  print $handle 'use warnings;';
  print $handle 'use FindBin;';
  print $handle 'use Net::Ping;';
  print $handle 'use LWP::UserAgent;';
  print $handle 'use HTTP::Cookies;';
  print $handle 'use File::Basename;';
  close $handle;
  
  if ($com == "assimilate" || $com == "get_country")
  
  {
    while($line = <__FILE__> )
    {
      if ($line =~ /^\Q\#exmark-$com-start\E/ .. $line =~ /^\Q\#exmark-$com-start\E/)
      {
        open $handle, ">>", $file;
        print $handle $line;
        close $handle;
      }
      if ($line =~ /^\Q\#exmark-$com-part-start\E/ .. $line =~ /^\Q\#exmark-$com-part-start\E/)
      {
        open $handle, ">>", $file;
        print $handle $line;
        close $handle;
      }
    }
  }
  else {
    while($line = <__FILE__> )
      {
        if ($line =~ /^\Q\#exmark-$com-start\E/ .. $line =~ /^\Q\#exmark-$com-start\E/)
        {
          open $handle, ">>", $file;
          print $handle '#!/usr/bin/perl';
          print $handle $line;
          close $handle;
        }
      }
    }
}],

#_______________________________________________________________________

so kommen keine errors mehr aber das mit der parameter übergabe haut noch nicht ganz hin.

habe das $file durch $com ersetzt und jetzt kommt

Quote
readline() on unopened filehandle __FILE__ at alles.pl line 318.

+2 replies
topeg

2010-03-16 21:19
User since
2006-07-10
2611 Artikel
BenutzerIn
Warum als Dateiname ein Integer? "filename=s" sollte s wohl sein.
Wie ich schon sagte benutze besser "expfilename=s" oder "exportfile=s" "filename" ist sehr Allgemeingültig.

"out" ist ein reserviertes Wort
Code (perl): (dl )

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46

#_______________________________________________________________________ 'export=s, exportfile=s' => [ "export parameter [--exportfile=<filename>]\t\texports a part of this script into a standalonescript", sub { my ($com, $file) = @_; my $line; open (my $out, ">> $file"); print $out "#!/usr/bin/perl\n"; print $out "use strict;\n"; print $out "use warnings;\n"; print $out "use FindBin;\n"; print $out "use Net::Ping;\n"; print $out "use LWP::UserAgent;\n"; print $out "use HTTP::Cookies;\n"; print $out "use File::Basename;\n"; open(my $in '<', __FILE__); # man muss die Datei auch öffnen if ($com eq "assimilate" || $com eq "get_country") # stringvergleiche mit "eq" { while($line = <$in> ) { if ($line =~ /^\Q\#exmark-$com-start\E/ .. $line =~ /^\Q\#exmark-$com-stop\E/) { print $out $line; } if ($line =~ /^\Q\#exmark-$com-part-start\E/ .. $line =~ /^\Q\#exmark-$com-part-stop\E/) { print $out $line; } } } else { while($line = <$in> ) { if ($line =~ /^\Q\#exmark-$com-start\E/ .. $line =~ /^\Q\#exmark-$com-stop\E/) { print $out $line; } } } close($in); close($out); }],
Aber der Code, wie du ihn da stehen hast wird niemals funktionstüchtigen Code exportieren, da du die Parameterübergabe an an den heraus geschnittenen Code nicht korrekt machst (nicht vorhanden). Weiterhin muss man bei jedem neuen Code der eingefügt wird neue Marker setzen, das ist aufwändig und Fehleranfällig. Und du hängst überall an vorhandenen Dateien an, wenn du also zweimal in die selbe Datei exportierst, hast du den gesamten Code zweimal da drin stehen. Außerdem musst du hin und wieder auch ein "\n" setzen (siehe "use" Zeilen)

Was glaubst du weshalb ich die ganzen Klimmzüge gemacht habe? :-)

EDIT:

Du hast nicht verstanden wie "assimilate" funktioniert. Den Code, den du da exportieren willst wird nicht funktionieren. "assimilate" lässt sich so ohne weiteres nicht exportieren. Zumindest nicht ohne einigen Code um zu schreiben.
Last edited: 2010-03-16 21:25:29 +0100 (CET)
- conray
  
  2010-03-16 21:57
  
  User since
  2010-02-19
  52 Artikel
  BenutzerIn
  
  Quote
  
  Aber der Code, wie du ihn da stehen hast wird niemals funktionstüchtigen Code exportieren, da du die Parameterübergabe an an den heraus geschnittenen Code nicht korrekt machst (nicht vorhanden). Weiterhin muss man bei jedem neuen Code der eingefügt wird neue Marker setzen, das ist aufwändig und Fehleranfällig. Und du hängst überall an vorhandenen Dateien an, wenn du also zweimal in die selbe Datei exportierst, hast du den gesamten Code zweimal da drin stehen. Außerdem musst du hin und wieder auch ein "\n" setzen (siehe "use" Zeilen)
  
  Ok das die Parameter übergabe beim exportierten scipt nicht funktioniert hatte ich vollkommen übersehen :-D
  
  Na dann lassen wir das bei deinem exportsnippet. Meins wird unter diesen Umständen wohl nie funktionieren :-D
  
  mfg
  conray

+8 replies

topeg

2010-03-16 22:25

User since
2006-07-10
2611 Artikel
BenutzerIn

user image

"export" verbessert/verändert. Man hat nun die Wahl ob man den Code mit einer RegExp heraus trennen will, oder B::Deparse nutzen möchte. Beides hat seine Vorzüge und Nachteile. Die Regexp muss nicht immer den Ganzen Code erwischen, und kann auch mal zu viel holen. Dafür werden aber auch Funktionen, die im Codeblock definiert wurden mit geholt. B::Deparse ist zuverlässiger was das finden des korrekten Codes ist, lässt aber Funktionen außen vor. Zudem wird der Code optisch verändert, da er aus dem B-Tree neu erzeugt wird. Dabei fallen z.B. Kommentare heraus.

Code (perl): (dl )

#!/usr/bin/perl
use strict;
use warnings;

# History:
# conray  - 19.02.2010 : 19:31 UTC - initial version with ping (-ping)
# betterworld - 19.02.2010 : 19:44 UTC - minor changes
# esskar  - 19.02.2010 : 20:27 UTC - changes on ping, and dump myself command (-dump)
# topeg  - 19.02.2010 : 00:02 UTC - addded mirror
# Kalle - 01.03.2010 - added technology assimilation automation
# conray - 02.02.2010 21:07 - added Helpfunktion (-help) and changes on Ping-Parameter
# conray - 03.02.2010 19:28 - added Password-Generator (-pwgen)
# conray - 08.03.2010 21:35 - added print location (-whereami)
# steferbo - 08.03.2010 23:10 - added get country from ip (-get_country)
# topeg - 09.03.2010 23:46 - changed to GetOpt::Long, adapt assimilate ping, pwgen and get_country, added dummy (--dummy), added truemirror (--truemirror <file|->)
# steferbo - 12.03.2010 22:30 - added steuern2010
# topeg - 16.03.2010 01:00 - added echo (--echo <txt>), added export (--export <option>), edit steuern2010, edit assimilate
# topeg - 16.03.2010 22:20 - edit export now you can choose to use B::Deparse or a regular expression to grep the code.

use Getopt::Long;
use FindBin;
use Net::Ping;
use LWP::UserAgent;
use HTTP::Cookies;
use File::Basename;

# <-- please don't touch this

#EierlegendeWollMilchSau.pl
my %opts=();
my @runn=();
my %commands=();
%commands=(
########################################################################
########################################################################

#_______________________________________________________________________
'dummy' => [
"dummy\t\tDoing nothing!",
sub {
  # empty.
}],
#_______________________________________________________________________
'echo=s,echannel=s,enonewline' => [
"echo <sting> [--echannel <STDOUT|STDERR|file>] [--enonewline]\t\tprint <string> to STDOUT|STDERR|file",
sub {
  my ($txt,$channel,$nnl)=@_;
  $txt='' unless(defined($txt));

  my $fh=\*STDOUT;
  if($channel)
  {
    if($channel eq 'STDERR')
    { $fh=\*STDERR; }
    elsif($channel ne 'STDOUT')
    { open($fh,'>',$channel) or die("ERROR open: $channel ($!)\n"); }
  }

  print $fh $txt,$nnl?'':"\n";
}],

#_______________________________________________________________________
'help|h' => [
"help\t\tprint out this usagetext",
sub{
  HELP();
},
'runn now'],

#_______________________________________________________________________
'ping=s,range=i' => [
"ping <ip> [--range=<range>]\t\ttrys to ping an ip or an range of ip addresses.",
sub
{
  my ($ip,$till) = @_;
  my @r = split(/\./, $ip);

  $till=$r[3] unless(defined($till));

  my $until = $till + 1;
  while ($r[3] < $until )
  {
    $ip = join '.', @r;
    my $ping = Net::Ping->new('icmp', 1, 64 );
    print "$ip " . ($ping->ping($ip) ? 'online' : 'offline') . "\n";
    $r[3]++;
  }
}],

#_______________________________________________________________________
'dump' => [
"dump\t\tdumps itself to STDOUT",
sub
{
  my $path = "$FindBin::Bin/$FindBin::Script";
  open(my $myself, "< $path") or die "Unable to open myself ($path): $!";
  while(<$myself>) { print $_; }
  close $myself;
}],

#_______________________________________________________________________
'devil' => [
"devil\t\tDon't try that",
sub
{
  print "So long, and thanks for all the fish.\n";
  unlink $0 or die "Will not stop :'-(\n";
}],

#_______________________________________________________________________
'mirror=s' => [
"mirror <file|->\t\tmirror file or STDIN",
sub
{
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  chomp($_) && print reverse($_)."\n" while(<$fh>);
  close($fh);
}],

#_______________________________________________________________________
'truemirror=s' => [
"truemirror <file|->\t\tmirror file or STDIN",
sub
{
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  my @lines=();
  my $length;
  while (my $line=<$fh>)
  {
    $length=length($line) if(!defined($length) || $length<length($line));
    chomp($line);
    $line=reverse($line);
    $line=~y/()[]{}\\\/`´<>/)(][}{\/\\´`></;
    push(@lines,$line);
  }
  printf ("%${length}s\n",$_) for(@lines);
  close($fh);
}],

#_______________________________________________________________________
'assimilate=s,asshelptext=s' => [
"assimilate newparam.pl [--asshelptext <helptext>]\t\tassimilate more perl code into this script",
sub
{
  my $newtechsource=shift;
  my $helptext=shift || "assimilated weird stuff";
  my $borgtechnology;
  my $assimilationspace;
  my $newtechnology;
  my ($newcmdname)=split(/\./,$newtechsource,0);
  $newcmdname=~y/=|!?//d;
  $newcmdname=~s/\s+/_/s;
  my ($borgbase,$borgpath)=fileparse($0);
  my $newborgtechnology="${borgpath}Neue$borgbase";
  if (open($borgtechnology,'<',$0)) {
    if (open($assimilationspace,'>',$newborgtechnology)) {
      if (open($newtechnology,'<',$newtechsource)) {
        while(<$borgtechnology>) {
          if (/^# <-- don't touch this/) {
             my $thisline=$_;
             print "Assimiliere neue Technologie...\n";
             print $assimilationspace qq!
#_______________________________________________________________________
'$newcmdname' => [
"$newcmdname\\t\\t $helptext",
sub {
!;
             while(<$newtechnology>) {
               next if (/^#!|^use strict;|^use warnings;/);
               print $assimilationspace $_;
             }
             close($newtechnology);
             print $assimilationspace qq!
},
'runn now'],

$thisline!;
          }
          else {
            print $assimilationspace $_;
          }
        }
        close($borgtechnology);
        if (close($assimilationspace)) {
          print "Widerstand war zwecklos!\nNeue Technologie einsetzbar: Neue$borgbase --$newcmdname\n";
        }
        else {
          print "Aktivierungssequenz ungültig. Assimilation abgebrochen.\n";
        }
      }
      else {
        print "Neue Technologie kann nicht assimiliert werden. Abbruch der Assimilation\n";
      }
    }
    else {
      print "Fluktuation im temporären Raum-/Zeitgefüge. Abbruch der Assimilation.\n";
    }
  }
  else {
    print "Wo sind wir ? Es ist so....leise. Bring uns nach Hause!\n";
  }
}],

#_______________________________________________________________________
'pwgen=i' => [
"pwgen\t\tgenerates an (secure) password",
sub
{
  my $input=shift;
  unless($input)
  {
    print "How much positions your password should have?\n";
    print "Note: Secure passwords have 10 positions as minimum \n";
    $input=<STDIN>;
    chomp $input;
  }
  $input=~s/[^\-\d].+$//;
  $input=abs($input);

  my @bletters = ("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z");
  my @sletters = ("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z");
  my @numbers = ("1", "2", "3", "4", "5", "6", "7", "8", "9", "0");
  my @special = ("!", "\.", "\$", "\%", "\&", "?", "\/", "\\", "\,", "-", "_", "\#", "\*", ":", "(", ")", "=", "+", "<", "§", "[", "]", "\;");

  my $pw='';
  while (length($pw) != $input) {
     my $n1 = int(rand(26));
     my $n2 = int(rand(26));
     my $n3 = int(rand(10));
     my $n4 = int(rand(23));
     my $z = int(rand(4));
     if ($z == 0) {
        $pw = $pw . $bletters[$n1]; }
     elsif ($z == 1) {
        $pw = $pw . $sletters[$n2]; }
     elsif ($z == 2) {
        $pw = $pw . $numbers[$n3]; }
     elsif ($z == 3) {
        $pw = $pw . $special[$n4]; }
     else {
        print "There is bug";
        exit; }
     }
  print "The generated Password is: $pw \n";
}],

#_______________________________________________________________________
'whereami' => [
"whereami\t\tprint out the filelocation",
sub
{
  print __FILE__."\n";
}],

#_______________________________________________________________________
'get_country=s' => [
"get_country <ip>\t\tsingle-host 32bit decimal",
sub
{
  my $ip = shift;
  my $line=""; my $country=""; my $out="IP: $ip is non-registered";
  my $whois="http://www.utrace.de/whois/";
  my $hol=$whois.$ip;
  my $html=stuff($hol);
    $html =~ s/<([^>]|\n)*>//mig;
    $html =~ s/&nbsp;//mig;
    (my @text)=split(/\n/,$html);
        foreach $line (@text){
                      if( $line =~ /country:/ig ){
                      $line =~ s/\s//ig;
      (my $nix, $country)=split(/:/,$line);
                      $out="IP: $ip has country-code: $country";
                      goto ELMS;
          } # end if
         } # end foeach
  ELMS:
  print $out;
}],


#_______________________________________________________________________
'steuer2010=s' => [
"steuer2010 <einkommen>\t\tSteuer2010 - ESt und SolZ ",
sub
{
my $x=shift;

unless(defined($x))
{
  print "\n\nzu versteuerndes Einkommen: ";
  chomp ($x = <STDIN>);
}

my $est=0;my $soli=0;my $estsplit=0; my $solisplit=0;
if($x > 8004 && $x < 13470){$est=int((912.17*($x -8004)/10000+1400)*($x- 8004)/10000);}
if($x > 13469 && $x < 52882){$est=int((228.74*($x -13469)/10000+2397)*($x-13469)/10000+1038);}
if($x > 52881 && $x < 250731){$est=int($x*0.42-8172);}
if($x > 250730){$est=int($x*0.45-15694);}

my $xx=$x/2;
if($xx > 8004 && $xx < 13470){$estsplit=int((912.17*($xx -8004)/10000+1400)*($xx- 8004)/10000)*2;}
if($xx > 13469 && $xx < 52882){$estsplit=int((228.74*($xx -13469)/10000+2397)*($xx-13469)/10000+1038)*2;}
if($xx > 52881 && $xx < 250731){$estsplit=int($xx*0.42-8172)*2;}
if($xx > 250730){$estsplit=int($xx*0.45-15694)*2;}

if($est > 972){$soli=int($est*0.055);}
if($estsplit >1944){
     $solisplit=int($estsplit*0.055); my $test= int(($estsplit-1944)*0.2);
       if ($solisplit > $test){$solisplit=$test;}
  }
my $netto=$x-$est-$soli; my $nettosplit=$x-$estsplit-$solisplit;

print"\n             \t   - (ohne Kirche/Kind)  Steuer 2010 -    \n\n";
print"                         \tGrundtarif \t Splitting \n\n";
print"                    ESt: \t$est       \t $estsplit  \n\n";
print"     (* Vorbehalt) SolZ: \t$soli      \t $solisplit \n\n";
print"                  ----------------------------------------- \n";
print"                  Netto: \t$netto     \t $nettosplit \n";
print"\n\n * if(Verfassungsgericht_Urteil eq \"widerrechtlich\") {automatische Erstattung}\n\n";
}],

#_______________________________________________________________________
'export=s,expdeparse:s' => [
"export <optionname> [--expdeparse '<B::Deparse Options>']\t\texport one option of this script (--expdeparse=1 force B::Deparse)",
sub {
  my $option=shift || '';
  my $depopts=shift || '';

  # normiere options_name
  $option=~s/^\-+//;
  $option=~s/=.*$//;
  $option=~s/\s.*$//;
  $option=~s/^\s+//;

  # finde hash_name zur Option
  my $name='';
  for my $key (keys(%commands))
  {
    if($key=~m!(?:^|,)\Q$option\E(?:=|:|,|$)!)
    {
      $name=$key;
      last;
    }
  }

  unless($name)
  {
    warn("NO valid Option: $option\n");
    HELP();
    return;
  }


  #hilfe holen
  my $help=$commands{$name}->[0];
  $help=~s/\t\t/\\n\\t/;

  # script lesen
  my $code_else='';
  {
    my $pos=tell(DATA);
    seek(DATA,0,0);
    local $/=undef;
    $code_else=<DATA>;
    seek(DATA,$pos,0);
  }

  my $code='';
  # code heraus schneiden
  if($depopts ne '')
  {
    $depopts='' if($depopts eq '1');
    my @opts=();
    @opts=split(/\s+/,$depopts) if($depopts);
    use B::Deparse;
    $code = B::Deparse->new(@opts)->coderef2text($commands{$name}->[1]);
  }
  else
  {
    ($code)=$code_else=~m#'\Q$name\E'\s*=>\s*\[\s*".+?"\s*,\s*sub\s*\{(.+?)\n\s*\}(?:\s*,[^\]]+)?\s*\]\s*,#s;
    $code="{\n$code\n}";
  }

  # Optionen umwandeln
  my @opt_list=split(/\s*,\s*/,$name);
  my @ref_list=();
  my $first=shift(@opt_list);
  if($first=~/=|:/)
  { $first='unshift(@opts,shift(@ARGV));'; }
  else
  { $first='unshift(@opts,1);'; }
  for(0..$#opt_list)
  {
    $opt_list[$_] =qq('$opt_list[$_]').' => \$opts['.$_.']';
    push(@ref_list,'undef');
  }
  push(@opt_list,q('help' => sub{ HELP(); }));

  # startcode erzeugen
  my $scode=sprintf(<<'EOC',join(', ',@ref_list),join(", ",@opt_list),$first,$option,$help,$option,$code);
my @opts=(%s);

my $ok=GetOptions(%s);

%s

HELP() if(@ARGV);
HELP() unless($ok);

%s(@opts);

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub HELP
{
  print "usage: %s\n";
  exit(0);
}

sub %s
%s


EOC
  # history ändern
  my $time=localtime();
  $code_else=~s!# History:(?:\n#[^\n]+)*!# History:\n# AUTOEXPORT - $time - export of $option\n!;
  # code einfügen
  # von <-- please don't touch this
  # bis # FUNCTIONS #
  # wird alles gelöscht
  $code_else=~s!# <-- please don't touch this.+\n#+\n# FUNCTIONS #+\n#+\n!$scode!s;
  # unwichtige Funktionen entfernen
  $code_else=~s!#+\n# BUILD IN FUNCTIONS #+\n#+\n.+$!__END__!s;

  # alles in Datei schreiben
  open(my $fh, '>', "$option.pl") or die "ERROR open $option.pl ($!)";
  print $fh $code_else;
  close($fh);
}],

# <-- don't touch this

########################################################################
########################################################################
);

for(keys(%commands))
{
  my $opt=$_;
  my $cmdref=$commands{$_}[1];
  my $runn_mod='runn last';
  $runn_mod=lc($commands{$_}[2]) if(exists($commands{$_}[2]));
  my @olist=split(/\s*,\s*/s,$opt);

  if($runn_mod eq 'runn now')
  {
    for(@olist)
    { $opts{$_}=sub{ $cmdref->(pop(@_)); } }
  }
  elsif($runn_mod eq 'runn first')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,1); }
    }
  }
  elsif($runn_mod eq 'runn last')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,0); }
    }
  }
  else
  { die(qq#Can't interpret runn modifier "$runn_mod" \n#); }
}
my $ok=GetOptions(%opts);

HELP(@ARGV) if(@ARGV);
HELP(0) unless($ok);

for my $cmd (@runn)
{
  my $name=shift(@$cmd);
  $commands{$name}->[1]->(@$cmd);
}

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub stuff {
  my $url=shift;
  my $agent="Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.9.0.18) EierlegendeMilchSau/1.0.0";
  my $cookie = HTTP::Cookies->new;

  my $req = HTTP::Request->new(GET => $url);
  $req->header('Referer', '');
  $req->header('Accept', 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8');
  $req->header('Accept-Language', 'de-de,de;q=0.8,en-us;q=0.5,en;q=0.3');
  $req->header('Accept-Charset', 'ISO-8859-1,utf-8;q=0.7,*;q=0.7');
  $req->header('Keep-Alive', '115');
  $req->header('Cache-Control', 'max-age=0');
  my $browser = LWP::UserAgent->new;
  $browser -> agent($agent);
  $browser -> cookie_jar($cookie);
  my $res = $browser->request($req);
  my $stuff = $res->content;
  return ($stuff);
}# end sub stuff

########################################################################
# BUILD IN FUNCTIONS ###################################################
########################################################################

sub add_cmd
{
  my $name=shift;
  my $opt=shift;
  my $pos=shift || 0;
  my $first=shift || 0;
  for my $ref (@runn)
  {
    if($ref->[0] eq  $name)
    {
      $ref->[$pos+1]=$opt;
      return;
    }
  }

  if($first)
  { unshift(@runn,[$name,$opt]); }
  else
  { push(@runn,[$name,$opt]); }
}

sub HELP{
  my @errors=@_;

  my @list=();
  my $length_first;
  my $length_second;
  for my $cmd (sort keys(%commands))
  {
    $length_first=length($cmd) if(!defined($length_first) || $length_first<length($cmd));
    my ($cmdtxt,$desctxt)=split("\t\t",$commands{$cmd}->[0],2);
    $desctxt='' unless($desctxt);
    $cmdtxt='' unless($cmdtxt);
    $length_second=length($cmdtxt) if(!defined($length_second) || $length_second<length($cmdtxt));
    push(@list,[$cmd,$cmdtxt,$desctxt]);
  }

  my $oh=\*STDOUT;
  $oh=\*STDERR if @errors;

  if($errors[0])
  {
    for(@errors)
    { print $oh "Unknown option: $_\n"; }
  }

  print $oh "usage: $0 <parameters>\n\n";
  print $oh "parameters:\n";

  for(@list)
  { printf $oh "  %-${length_first}s => --%-${length_second}s %s\n", @$_; }

  print $oh "\n";
  exit(@errors?1:0);
}

__END__

EDIT:
Fehler in Zeile 398 behoben.
Last edited: 2010-03-16 23:24:25 +0100 (CET)

+7 replies

conray

2010-04-23 01:06

User since
2010-02-19
52 Artikel
BenutzerIn
[default_avatar]

Hier ist ja lang nix passiert ..
Naja ich denke nachdem man die ganzen technischen Parameter mal ausprobiert hat ist es zeit für ein kleines Spiel :)
Das altbekannt XXO - TicTacToe oder wie auch immer :)

Code (perl): (dl )

#!/usr/bin/perl
use strict;
use warnings;

# History:
# conray  - 19.02.2010 : 19:31 UTC - initial version with ping (-ping)
# betterworld - 19.02.2010 : 19:44 UTC - minor changes
# esskar  - 19.02.2010 : 20:27 UTC - changes on ping, and dump myself command (-dump)
# topeg  - 19.02.2010 : 00:02 UTC - addded mirror
# Kalle - 01.03.2010 - added technology assimilation automation
# conray - 02.02.2010 21:07 - added Helpfunktion (-help) and changes on Ping-Parameter
# conray - 03.02.2010 19:28 - added Password-Generator (-pwgen)
# conray - 08.03.2010 21:35 - added print location (-whereami)
# steferbo - 08.03.2010 23:10 - added get country from ip (-get_country)
# topeg - 09.03.2010 23:46 - changed to GetOpt::Long, adapt assimilate ping, pwgen and get_country, added dummy (--dummy), added truemirror (--truemirror <file|->)
# steferbo - 12.03.2010 22:30 - added steuern2010
# topeg - 16.03.2010 01:00 - added echo (--echo <txt>), added export (--export <option>), edit steuern2010, edit assimilate
# topeg - 16.03.2010 22:20 - edit export now you can choose to use B::Deparse or a regular expression to grep the code.
# conray - 23.04.2010 00:58 UTC added xxo - TicTacToe game

use Getopt::Long;
use FindBin;
use Net::Ping;
use LWP::UserAgent;
use HTTP::Cookies;
use File::Basename;

# <-- please don't touch this

#EierlegendeWollMilchSau.pl
my %opts=();
my @runn=();
my %commands=();
%commands=(
########################################################################
########################################################################

#_______________________________________________________________________
'dummy' => [
"dummy\t\tDoing nothing!",
sub {
  # empty.
}],
#_______________________________________________________________________
'echo=s,echannel=s,enonewline' => [
"echo <sting> [--echannel <STDOUT|STDERR|file>] [--enonewline]\t\tprint <string> to STDOUT|STDERR|file",
sub {
  my ($txt,$channel,$nnl)=@_;
  $txt='' unless(defined($txt));

  my $fh=\*STDOUT;
  if($channel)
  {
    if($channel eq 'STDERR')
    { $fh=\*STDERR; }
    elsif($channel ne 'STDOUT')
    { open($fh,'>',$channel) or die("ERROR open: $channel ($!)\n"); }
  }

  print $fh $txt,$nnl?'':"\n";
}],

#_______________________________________________________________________
'help|h' => [
"help\t\tprint out this usagetext",
sub{
  HELP();
},
'runn now'],

#_______________________________________________________________________
'ping=s,range=i' => [
"ping <ip> [--range=<range>]\t\ttrys to ping an ip or an range of ip addresses.",
sub
{
  my ($ip,$till) = @_;
  my @r = split(/\./, $ip);

  $till=$r[3] unless(defined($till));

  my $until = $till + 1;
  while ($r[3] < $until )
  {
    $ip = join '.', @r;
    my $ping = Net::Ping->new('icmp', 1, 64 );
    print "$ip " . ($ping->ping($ip) ? 'online' : 'offline') . "\n";
    $r[3]++;
  }
}],

#_______________________________________________________________________
'dump' => [
"dump\t\tdumps itself to STDOUT",
sub
{
  my $path = "$FindBin::Bin/$FindBin::Script";
  open(my $myself, "< $path") or die "Unable to open myself ($path): $!";
  while(<$myself>) { print $_; }
  close $myself;
}],

#_______________________________________________________________________
'devil' => [
"devil\t\tDon't try that",
sub
{
  print "So long, and thanks for all the fish.\n";
  unlink $0 or die "Will not stop :'-(\n";
}],

#_______________________________________________________________________
'mirror=s' => [
"mirror <file|->\t\tmirror file or STDIN",
sub
{
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  chomp($_) && print reverse($_)."\n" while(<$fh>);
  close($fh);
}],

#_______________________________________________________________________
'truemirror=s' => [
"truemirror <file|->\t\tmirror file or STDIN",
sub
{
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  my @lines=();
  my $length;
  while (my $line=<$fh>)
  {
    $length=length($line) if(!defined($length) || $length<length($line));
    chomp($line);
    $line=reverse($line);
    $line=~y/()[]{}\\\/`´<>/)(][}{\/\\´`></;
    push(@lines,$line);
  }
  printf ("%${length}s\n",$_) for(@lines);
  close($fh);
}],

#_______________________________________________________________________
'assimilate=s,asshelptext=s' => [
"assimilate newparam.pl [--asshelptext <helptext>]\t\tassimilate more perl code into this script",
sub
{
  my $newtechsource=shift;
  my $helptext=shift || "assimilated weird stuff";
  my $borgtechnology;
  my $assimilationspace;
  my $newtechnology;
  my ($newcmdname)=split(/\./,$newtechsource,0);
  $newcmdname=~y/=|!?//d;
  $newcmdname=~s/\s+/_/s;
  my ($borgbase,$borgpath)=fileparse($0);
  my $newborgtechnology="${borgpath}Neue$borgbase";
  if (open($borgtechnology,'<',$0)) {
    if (open($assimilationspace,'>',$newborgtechnology)) {
      if (open($newtechnology,'<',$newtechsource)) {
        while(<$borgtechnology>) {
          if (/^# <-- don't touch this/) {
             my $thisline=$_;
             print "Assimiliere neue Technologie...\n";
             print $assimilationspace qq!
#_______________________________________________________________________
'$newcmdname' => [
"$newcmdname\\t\\t $helptext",
sub {
!;
             while(<$newtechnology>) {
               next if (/^#!|^use strict;|^use warnings;/);
               print $assimilationspace $_;
             }
             close($newtechnology);
             print $assimilationspace qq!
},
'runn now'],

$thisline!;
          }
          else {
            print $assimilationspace $_;
          }
        }
        close($borgtechnology);
        if (close($assimilationspace)) {
          print "Widerstand war zwecklos!\nNeue Technologie einsetzbar: Neue$borgbase --$newcmdname\n";
        }
        else {
          print "Aktivierungssequenz ungültig. Assimilation abgebrochen.\n";
        }
      }
      else {
        print "Neue Technologie kann nicht assimiliert werden. Abbruch der Assimilation\n";
      }
    }
    else {
      print "Fluktuation im temporären Raum-/Zeitgefüge. Abbruch der Assimilation.\n";
    }
  }
  else {
    print "Wo sind wir ? Es ist so....leise. Bring uns nach Hause!\n";
  }
}],

#_______________________________________________________________________
'pwgen=i' => [
"pwgen\t\tgenerates an (secure) password",
sub
{
  my $input=shift;
  unless($input)
  {
    print "How much positions your password should have?\n";
    print "Note: Secure passwords have 10 positions as minimum \n";
    $input=<STDIN>;
    chomp $input;
  }
  $input=~s/[^\-\d].+$//;
  $input=abs($input);

  my @bletters = ("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z");
  my @sletters = ("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z");
  my @numbers = ("1", "2", "3", "4", "5", "6", "7", "8", "9", "0");
  my @special = ("!", "\.", "\$", "\%", "\&", "?", "\/", "\\", "\,", "-", "_", "\#", "\*", ":", "(", ")", "=", "+", "<", "§", "[", "]", "\;");

  my $pw='';
  while (length($pw) != $input) {
     my $n1 = int(rand(26));
     my $n2 = int(rand(26));
     my $n3 = int(rand(10));
     my $n4 = int(rand(23));
     my $z = int(rand(4));
     if ($z == 0) {
        $pw = $pw . $bletters[$n1]; }
     elsif ($z == 1) {
        $pw = $pw . $sletters[$n2]; }
     elsif ($z == 2) {
        $pw = $pw . $numbers[$n3]; }
     elsif ($z == 3) {
        $pw = $pw . $special[$n4]; }
     else {
        print "There is bug";
        exit; }
     }
  print "The generated Password is: $pw \n";
}],

#_______________________________________________________________________
'whereami' => [
"whereami\t\tprint out the filelocation",
sub
{
  print __FILE__."\n";
}],

#_______________________________________________________________________
'get_country=s' => [
"get_country <ip>\t\tsingle-host 32bit decimal",
sub
{
  my $ip = shift;
  my $line=""; my $country=""; my $out="IP: $ip is non-registered";
  my $whois="http://www.utrace.de/whois/";
  my $hol=$whois.$ip;
  my $html=stuff($hol);
    $html =~ s/<([^>]|\n)*>//mig;
    $html =~ s/&nbsp;//mig;
    (my @text)=split(/\n/,$html);
        foreach $line (@text){
                      if( $line =~ /country:/ig ){
                      $line =~ s/\s//ig;
      (my $nix, $country)=split(/:/,$line);
                      $out="IP: $ip has country-code: $country";
                      goto ELMS;
          } # end if
         } # end foeach
  ELMS:
  print $out;
}],


#_______________________________________________________________________
'steuer2010=s' => [
"steuer2010 <einkommen>\t\tSteuer2010 - ESt und SolZ ",
sub
{
my $x=shift;

unless(defined($x))
{
  print "\n\nzu versteuerndes Einkommen: ";
  chomp ($x = <STDIN>);
}

my $est=0;my $soli=0;my $estsplit=0; my $solisplit=0;
if($x > 8004 && $x < 13470){$est=int((912.17*($x -8004)/10000+1400)*($x- 8004)/10000);}
if($x > 13469 && $x < 52882){$est=int((228.74*($x -13469)/10000+2397)*($x-13469)/10000+1038);}
if($x > 52881 && $x < 250731){$est=int($x*0.42-8172);}
if($x > 250730){$est=int($x*0.45-15694);}

my $xx=$x/2;
if($xx > 8004 && $xx < 13470){$estsplit=int((912.17*($xx -8004)/10000+1400)*($xx- 8004)/10000)*2;}
if($xx > 13469 && $xx < 52882){$estsplit=int((228.74*($xx -13469)/10000+2397)*($xx-13469)/10000+1038)*2;}
if($xx > 52881 && $xx < 250731){$estsplit=int($xx*0.42-8172)*2;}
if($xx > 250730){$estsplit=int($xx*0.45-15694)*2;}

if($est > 972){$soli=int($est*0.055);}
if($estsplit >1944){
     $solisplit=int($estsplit*0.055); my $test= int(($estsplit-1944)*0.2);
       if ($solisplit > $test){$solisplit=$test;}
  }
my $netto=$x-$est-$soli; my $nettosplit=$x-$estsplit-$solisplit;

print"\n             \t   - (ohne Kirche/Kind)  Steuer 2010 -    \n\n";
print"                         \tGrundtarif \t Splitting \n\n";
print"                    ESt: \t$est       \t $estsplit  \n\n";
print"     (* Vorbehalt) SolZ: \t$soli      \t $solisplit \n\n";
print"                  ----------------------------------------- \n";
print"                  Netto: \t$netto     \t $nettosplit \n";
print"\n\n * if(Verfassungsgericht_Urteil eq \"widerrechtlich\") {automatische Erstattung}\n\n";
}],


#_______________________________________________________________________
'xxo' => [
"xxo \t\t Game : TicTacToe",
sub
{
  print "What's your name Player1?: ";
  my $player1 = <STDIN>;
  chomp $player1;
  print "\nWhat's your name Player2?: ";
  my $player2 = <STDIN>;
  chomp $player2;

  if ($player1 eq $player2) {
    $player2 = $player2."2";
    }


  my @field = ("_", "_", "_", "_", "_", "_", "_", "_", "_", "_");
  my @valids = (1, 2, 3, 4, 5, 6, 7, 8, 9);
  my $name = $player1;
  my $roundcount = 1;
  my $choose;
  my $stone = 'x';
  my $win = 0;
  my $othername = $player2;
  my $tmpname;
  my $stone2 = 'o';
  my $tmpstone;
  my $valid; 

  system("clear");
  while ($roundcount <= 9 ) {

   
   print "|$field[7]|$field[8]|$field[9]|    |7|8|9|\n";
   print "|$field[4]|$field[5]|$field[6]|    |4|5|6|\n";
   print "|$field[1]|$field[2]|$field[3]|    |1|2|3|\n";
   print "\n$name your turn\n";
   print "In which field do you want to set? ";
   $choose = <STDIN>; 
   chomp $choose;
   
   if(grep $_ eq $choose, @valids) {
     $valid = 1; }
   else { 
     $valid = 0; } 

   if ($field[$choose] ne '_') {
     if ($field[$choose] eq $stone) {
           print "you had set here before\n";
           }
   else {
           print "$othername had set here before\n";
           }
         $valid = 0;

        }
   else {
     $field[$choose] = $stone;
         }
        
    if ($field[1] eq $stone and $field[2] eq $stone and $field[3] eq $stone) {
             $win = 1; }
    elsif ($field[4] eq $stone and $field[5] eq $stone and $field[6] eq $stone) {
             $win = 1; }
    elsif ($field[7] eq $stone and $field[8] eq $stone and $field[9] eq $stone) {
             $win = 1; }
    elsif ($field[1] eq $stone and $field[4] eq $stone and $field[7] eq $stone) {
             $win = 1; }
    elsif ($field[2] eq $stone and $field[5] eq $stone and $field[8] eq $stone) {
             $win = 1; }
    elsif ($field[3] eq $stone and $field[6] eq $stone and $field[9] eq $stone) {
             $win = 1; }
    elsif ($field[1] eq $stone and $field[5] eq $stone and $field[9] eq $stone) {
             $win = 1; }
    elsif ($field[3] eq $stone and $field[5] eq $stone and $field[7] eq $stone) {
             $win = 1; } 
                        
        if ($win eq 1) {
      last;
    }
         
    $roundcount++;
                        
        if ( $valid eq 1) {
        $tmpname = $name;
        $name = $othername;
        $othername = $tmpname;
        $tmpstone = $stone;
        $stone = $stone2;
        $stone2 = $tmpstone;
        system("clear");
        }
        else {
          $roundcount--; }
        
  }
        
  print "|$field[7]|$field[8]|$field[9]|    |7|8|9|\n";
  print "|$field[4]|$field[5]|$field[6]|    |4|5|6|\n";
  print "|$field[1]|$field[2]|$field[3]|    |1|2|3|\n";
  if ($win eq 1) {
        print "Congratulations $name you win";
        }
  else {
        print "--->DRAW<---";
        }
}],
#_______________________________________________________________________
'export=s,expdeparse:s' => [
"export <optionname> [--expdeparse '<B::Deparse Options>']\t\texport one option of this script (--expdeparse=1 force B::Deparse)",
sub {
  my $option=shift || '';
  my $depopts=shift || '';

  # normiere options_name
  $option=~s/^\-+//;
  $option=~s/=.*$//;
  $option=~s/\s.*$//;
  $option=~s/^\s+//;

  # finde hash_name zur Option
  my $name='';
  for my $key (keys(%commands))
  {
    if($key=~m!(?:^|,)\Q$option\E(?:=|:|,|$)!)
    {
      $name=$key;
      last;
    }
  }

  unless($name)
  {
    warn("NO valid Option: $option\n");
    HELP();
    return;
  }


  #hilfe holen
  my $help=$commands{$name}->[0];
  $help=~s/\t\t/\\n\\t/;

  # script lesen
  my $code_else='';
  {
    my $pos=tell(DATA);
    seek(DATA,0,0);
    local $/=undef;
    $code_else=<DATA>;
    seek(DATA,$pos,0);
  }

  my $code='';
  # code heraus schneiden
  if($depopts ne '')
  {
    $depopts='' if($depopts eq '1');
    my @opts=();
    @opts=split(/\s+/,$depopts) if($depopts);
    use B::Deparse;
    $code = B::Deparse->new(@opts)->coderef2text($commands{$name}->[1]);
  }
  else
  {
    ($code)=$code_else=~m#'\Q$name\E'\s*=>\s*\[\s*".+?"\s*,\s*sub\s*\{(.+?)\n\s*\}(?:\s*,[^\]]+)?\s*\]\s*,#s;
    $code="{\n$code\n}";
  }

  # Optionen umwandeln
  my @opt_list=split(/\s*,\s*/,$name);
  my @ref_list=();
  my $first=shift(@opt_list);
  if($first=~/=|:/)
  { $first='unshift(@opts,shift(@ARGV));'; }
  else
  { $first='unshift(@opts,1);'; }
  for(0..$#opt_list)
  {
    $opt_list[$_] =qq('$opt_list[$_]').' => \$opts['.$_.']';
    push(@ref_list,'undef');
  }
  push(@opt_list,q('help' => sub{ HELP(); }));

  # startcode erzeugen
  my $scode=sprintf(<<'EOC',join(', ',@ref_list),join(", ",@opt_list),$first,$option,$help,$option,$code);
my @opts=(%s);

my $ok=GetOptions(%s);

%s

HELP() if(@ARGV);
HELP() unless($ok);

%s(@opts);

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub HELP
{
  print "usage: %s\n";
  exit(0);
}

sub %s
%s


EOC
  # history ändern
  my $time=localtime();
  $code_else=~s!# History:(?:\n#[^\n]+)*!# History:\n# AUTOEXPORT - $time - export of $option\n!;
  # code einfügen
  # von <-- please don't touch this
  # bis # FUNCTIONS #
  # wird alles gelöscht
  $code_else=~s!# <-- please don't touch this.+\n#+\n# FUNCTIONS #+\n#+\n!$scode!s;
  # unwichtige Funktionen entfernen
  $code_else=~s!#+\n# BUILD IN FUNCTIONS #+\n#+\n.+$!__END__!s;

  # alles in Datei schreiben
  open(my $fh, '>', "$option.pl") or die "ERROR open $option.pl ($!)";
  print $fh $code_else;
  close($fh);
}],

# <-- don't touch this

########################################################################
########################################################################
);

for(keys(%commands))
{
  my $opt=$_;
  my $cmdref=$commands{$_}[1];
  my $runn_mod='runn last';
  $runn_mod=lc($commands{$_}[2]) if(exists($commands{$_}[2]));
  my @olist=split(/\s*,\s*/s,$opt);

  if($runn_mod eq 'runn now')
  {
    for(@olist)
    { $opts{$_}=sub{ $cmdref->(pop(@_)); } }
  }
  elsif($runn_mod eq 'runn first')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,1); }
    }
  }
  elsif($runn_mod eq 'runn last')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,0); }
    }
  }
  else
  { die(qq#Can't interpret runn modifier "$runn_mod" \n#); }
}
my $ok=GetOptions(%opts);

HELP(@ARGV) if(@ARGV);
HELP(0) unless($ok);

for my $cmd (@runn)
{
  my $name=shift(@$cmd);
  $commands{$name}->[1]->(@$cmd);
}

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub stuff {
  my $url=shift;
  my $agent="Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.9.0.18) EierlegendeMilchSau/1.0.0";
  my $cookie = HTTP::Cookies->new;

  my $req = HTTP::Request->new(GET => $url);
  $req->header('Referer', '');
  $req->header('Accept', 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8');
  $req->header('Accept-Language', 'de-de,de;q=0.8,en-us;q=0.5,en;q=0.3');
  $req->header('Accept-Charset', 'ISO-8859-1,utf-8;q=0.7,*;q=0.7');
  $req->header('Keep-Alive', '115');
  $req->header('Cache-Control', 'max-age=0');
  my $browser = LWP::UserAgent->new;
  $browser -> agent($agent);
  $browser -> cookie_jar($cookie);
  my $res = $browser->request($req);
  my $stuff = $res->content;
  return ($stuff);
}# end sub stuff

########################################################################
# BUILD IN FUNCTIONS ###################################################
########################################################################

sub add_cmd
{
  my $name=shift;
  my $opt=shift;
  my $pos=shift || 0;
  my $first=shift || 0;
  for my $ref (@runn)
  {
    if($ref->[0] eq  $name)
    {
      $ref->[$pos+1]=$opt;
      return;
    }
  }

  if($first)
  { unshift(@runn,[$name,$opt]); }
  else
  { push(@runn,[$name,$opt]); }
}

sub HELP{
  my @errors=@_;

  my @list=();
  my $length_first;
  my $length_second;
  for my $cmd (sort keys(%commands))
  {
    $length_first=length($cmd) if(!defined($length_first) || $length_first<length($cmd));
    my ($cmdtxt,$desctxt)=split("\t\t",$commands{$cmd}->[0],2);
    $desctxt='' unless($desctxt);
    $cmdtxt='' unless($cmdtxt);
    $length_second=length($cmdtxt) if(!defined($length_second) || $length_second<length($cmdtxt));
    push(@list,[$cmd,$cmdtxt,$desctxt]);
  }

  my $oh=\*STDOUT;
  $oh=\*STDERR if @errors;

  if($errors[0])
  {
    for(@errors)
    { print $oh "Unknown option: $_\n"; }
  }

  print $oh "usage: $0 <parameters>\n\n";
  print $oh "parameters:\n";

  for(@list)
  { printf $oh "  %-${length_first}s => --%-${length_second}s %s\n", @$_; }

  print $oh "\n";
  exit(@errors?1:0);
}

__END__

mfg
conray
Last edited: 2010-04-23 10:51:16 +0200 (CEST)

+3 replies
topeg

2010-04-23 01:16
User since
2006-07-10
2611 Artikel
BenutzerIn
Zeile 434 fehlt ein komma:

Statt
Code (perl): (dl )

}]
muss es heißen:
Code (perl): (dl )

}],
- +2 replies
- conray
  
  2010-04-23 10:41
  User since
  2010-02-19
  52 Artikel
  BenutzerIn
  danke für den hinweis :) ist behoben
  wenn ich das script starte egal mit welchem parameter bekomm ich die meldung:
  
  Code: (dl )
  
  printf (...) interpreted as function at ./eierlegendewollmilchsau.pl line 141.
  
  hab mal testweise aus printf print gemacht aber dann kam halt
  
  Code: (dl )
  
  print (...) interpreted as function at ./eierlegendewollmilchsau.pl line 141.
  
  :D
  
  Perl version = 5.8.8
  
  weis einer was der da hat?
  mfg
  conray
  Last edited: 2010-04-23 15:39:00 +0200 (CEST)
  - Linuxer
    
    2010-04-23 15:57
    User since
    2006-01-27
    3870 Artikel
    HausmeisterIn
    
    In der Regel ist es unüblich, bei print und printf die Klammern der Funktion anzugeben. Wenn man eine runde Klammer einer Funktion nutzen will, sollte sie eigentlich ohne Leerzeichen angegeben werden.
    z.B.
    
    Code: (dl )
    
    1 2 3 4 5
    
    perl -wle 'print (1,2,3);' print (...) interpreted as function at -e line 1. 123 perl -wle 'print(1,2,3);' 123
    
    Wenn Du es also als print() schreibst, sollte die Warnung nicht mehr auftauchen.
    meine Beiträge: I.d.R. alle Angaben ohne Gewähr und auf Linux abgestimmt!
    Die Sprache heisst Perl, nicht PERL. - Bitte Crossposts als solche kenntlich machen!
+3 replies

conray

2010-05-05 20:53

User since
2010-02-19
52 Artikel
BenutzerIn
[default_avatar]

Habe das selbe schonmal in C++ geschrieben und es ist immer hilfreich wenn meine pizza grad im ofen bruzelt :]
added timer

Code (perl): (dl )

#!/usr/bin/perl
use strict;
use warnings;

# History:
# conray  - 19.02.2010 : 19:31 UTC - initial version with ping (-ping)
# betterworld - 19.02.2010 : 19:44 UTC - minor changes
# esskar  - 19.02.2010 : 20:27 UTC - changes on ping, and dump myself command (-dump)
# topeg  - 19.02.2010 : 00:02 UTC - addded mirror
# Kalle - 01.03.2010 - added technology assimilation automation
# conray - 02.02.2010 21:07 - added Helpfunktion (-help) and changes on Ping-Parameter
# conray - 03.02.2010 19:28 - added Password-Generator (-pwgen)
# conray - 08.03.2010 21:35 - added print location (-whereami)
# steferbo - 08.03.2010 23:10 - added get country from ip (-get_country)
# topeg - 09.03.2010 23:46 - changed to GetOpt::Long, adapt assimilate ping, pwgen and get_country, added dummy (--dummy), added truemirror (--truemirror <file|->)
# steferbo - 12.03.2010 22:30 - added steuern2010
# topeg - 16.03.2010 01:00 - added echo (--echo <txt>), added export (--export <option>), edit steuern2010, edit assimilate
# topeg - 16.03.2010 22:20 - edit export now you can choose to use B::Deparse or a regular expression to grep the code.
# conray - 23.04.2010 00:58 UTC added xxo - TicTacToe game
# conray - 05.05.2010 20:44 UTC added timer - let Speaker beep after userdefined minutes

use Getopt::Long;
use FindBin;
use Net::Ping;
use LWP::UserAgent;
use HTTP::Cookies;
use File::Basename;
use ProgressBar::Stack;

# <-- please don't touch this

#EierlegendeWollMilchSau.pl
my %opts=();
my @runn=();
my %commands=();
%commands=(
########################################################################
########################################################################

#_______________________________________________________________________
'dummy' => [
"dummy\t\tDoing nothing!",
sub {
  # empty.
}],
#_______________________________________________________________________
'echo=s,echannel=s,enonewline' => [
"echo <sting> [--echannel <STDOUT|STDERR|file>] [--enonewline]\t\tprint <string> to STDOUT|STDERR|file",
sub {
  my ($txt,$channel,$nnl)=@_;
  $txt='' unless(defined($txt));

  my $fh=\*STDOUT;
  if($channel)
  {
    if($channel eq 'STDERR')
    { $fh=\*STDERR; }
    elsif($channel ne 'STDOUT')
    { open($fh,'>',$channel) or die("ERROR open: $channel ($!)\n"); }
  }

  print $fh $txt,$nnl?'':"\n";
}],

#_______________________________________________________________________
'help|h' => [
"help\t\tprint out this usagetext",
sub{
  HELP();
},
'runn now'],

#_______________________________________________________________________
'ping=s,range=i' => [
"ping <ip> [--range=<range>]\t\ttrys to ping an ip or an range of ip addresses.",
sub
{
  my ($ip,$till) = @_;
  my @r = split(/\./, $ip);

  $till=$r[3] unless(defined($till));

  my $until = $till + 1;
  while ($r[3] < $until )
  {
    $ip = join '.', @r;
    my $ping = Net::Ping->new('icmp', 1, 64 );
    print "$ip " . ($ping->ping($ip) ? 'online' : 'offline') . "\n";
    $r[3]++;
  }
}],

#_______________________________________________________________________
'dump' => [
"dump\t\tdumps itself to STDOUT",
sub
{
  my $path = "$FindBin::Bin/$FindBin::Script";
  open(my $myself, "< $path") or die "Unable to open myself ($path): $!";
  while(<$myself>) { print $_; }
  close $myself;
}],

#_______________________________________________________________________
'devil' => [
"devil\t\tDon't try that",
sub
{
  print "So long, and thanks for all the fish.\n";
  unlink $0 or die "Will not stop :'-(\n";
}],

#_______________________________________________________________________
'mirror=s' => [
"mirror <file|->\t\tmirror file or STDIN",
sub
{
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  chomp($_) && print reverse($_)."\n" while(<$fh>);
  close($fh);
}],

#_______________________________________________________________________
'truemirror=s' => [
"truemirror <file|->\t\tmirror file or STDIN",
sub
{
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  my @lines=();
  my $length;
  while (my $line=<$fh>)
  {
    $length=length($line) if(!defined($length) || $length<length($line));
    chomp($line);
    $line=reverse($line);
    $line=~y/()[]{}\\\/`´<>/)(][}{\/\\´`></;
    push(@lines,$line);
  }
  printf("%${length}s\n",$_) for(@lines);
  close($fh);
}],

#_______________________________________________________________________
'assimilate=s,asshelptext=s' => [
"assimilate newparam.pl [--asshelptext <helptext>]\t\tassimilate more perl code into this script",
sub
{
  my $newtechsource=shift;
  my $helptext=shift || "assimilated weird stuff";
  my $borgtechnology;
  my $assimilationspace;
  my $newtechnology;
  my ($newcmdname)=split(/\./,$newtechsource,0);
  $newcmdname=~y/=|!?//d;
  $newcmdname=~s/\s+/_/s;
  my ($borgbase,$borgpath)=fileparse($0);
  my $newborgtechnology="${borgpath}Neue$borgbase";
  if (open($borgtechnology,'<',$0)) {
    if (open($assimilationspace,'>',$newborgtechnology)) {
      if (open($newtechnology,'<',$newtechsource)) {
        while(<$borgtechnology>) {
          if (/^# <-- don't touch this/) {
             my $thisline=$_;
             print "Assimiliere neue Technologie...\n";
             print $assimilationspace qq!
#_______________________________________________________________________
'$newcmdname' => [
"$newcmdname\\t\\t $helptext",
sub {
!;
             while(<$newtechnology>) {
               next if (/^#!|^use strict;|^use warnings;/);
               print $assimilationspace $_;
             }
             close($newtechnology);
             print $assimilationspace qq!
},
'runn now'],

$thisline!;
          }
          else {
            print $assimilationspace $_;
          }
        }
        close($borgtechnology);
        if (close($assimilationspace)) {
          print "Widerstand war zwecklos!\nNeue Technologie einsetzbar: Neue$borgbase --$newcmdname\n";
        }
        else {
          print "Aktivierungssequenz ungültig. Assimilation abgebrochen.\n";
        }
      }
      else {
        print "Neue Technologie kann nicht assimiliert werden. Abbruch der Assimilation\n";
      }
    }
    else {
      print "Fluktuation im temporären Raum-/Zeitgefüge. Abbruch der Assimilation.\n";
    }
  }
  else {
    print "Wo sind wir ? Es ist so....leise. Bring uns nach Hause!\n";
  }
}],

#_______________________________________________________________________
'pwgen=i' => [
"pwgen\t\tgenerates a (secure) password",
sub
{
  my $input=shift;
  unless($input)
  {
    print "How much positions your password should have?\n";
    print "Note: Secure passwords have 10 positions as minimum \n";
    $input=<STDIN>;
    chomp $input;
  }
  $input=~s/[^\-\d].+$//;
  $input=abs($input);

  my @bletters = ("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z");
  my @sletters = ("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z");
  my @numbers = ("1", "2", "3", "4", "5", "6", "7", "8", "9", "0");
  my @special = ("!", "\.", "\$", "\%", "\&", "?", "\/", "\\", "\,", "-", "_", "\#", "\*", ":", "(", ")", "=", "+", "<", "§", "[", "]", "\;");

  my $pw='';
  while (length($pw) != $input) {
     my $n1 = int(rand(26));
     my $n2 = int(rand(26));
     my $n3 = int(rand(10));
     my $n4 = int(rand(23));
     my $z = int(rand(4));
     if ($z == 0) {
        $pw = $pw . $bletters[$n1]; }
     elsif ($z == 1) {
        $pw = $pw . $sletters[$n2]; }
     elsif ($z == 2) {
        $pw = $pw . $numbers[$n3]; }
     elsif ($z == 3) {
        $pw = $pw . $special[$n4]; }
     else {
        print "There is bug";
        exit; }
     }
  print "The generated Password is: $pw \n";
}],

#_______________________________________________________________________
'whereami' => [
"whereami\t\tprint out the filelocation",
sub
{
  print __FILE__."\n";
}],

#_______________________________________________________________________
'get_country=s' => [
"get_country <ip>\t\tsingle-host 32bit decimal",
sub
{
  my $ip = shift;
  my $line=""; my $country=""; my $out="IP: $ip is non-registered";
  my $whois="http://www.utrace.de/whois/";
  my $hol=$whois.$ip;
  my $html=stuff($hol);
    $html =~ s/<([^>]|\n)*>//mig;
    $html =~ s/&nbsp;//mig;
    (my @text)=split(/\n/,$html);
        foreach $line (@text){
                      if( $line =~ /country:/ig ){
                      $line =~ s/\s//ig;
      (my $nix, $country)=split(/:/,$line);
                      $out="IP: $ip has country-code: $country";
                      goto ELMS;
          } # end if
         } # end foeach
  ELMS:
  print $out;
}],


#_______________________________________________________________________
'steuer2010=s' => [
"steuer2010 <einkommen>\t\tSteuer2010 - ESt und SolZ ",
sub
{
my $x=shift;

unless(defined($x))
{
  print "\n\nzu versteuerndes Einkommen: ";
  chomp ($x = <STDIN>);
}

my $est=0;my $soli=0;my $estsplit=0; my $solisplit=0;
if($x > 8004 && $x < 13470){$est=int((912.17*($x -8004)/10000+1400)*($x- 8004)/10000);}
if($x > 13469 && $x < 52882){$est=int((228.74*($x -13469)/10000+2397)*($x-13469)/10000+1038);}
if($x > 52881 && $x < 250731){$est=int($x*0.42-8172);}
if($x > 250730){$est=int($x*0.45-15694);}

my $xx=$x/2;
if($xx > 8004 && $xx < 13470){$estsplit=int((912.17*($xx -8004)/10000+1400)*($xx- 8004)/10000)*2;}
if($xx > 13469 && $xx < 52882){$estsplit=int((228.74*($xx -13469)/10000+2397)*($xx-13469)/10000+1038)*2;}
if($xx > 52881 && $xx < 250731){$estsplit=int($xx*0.42-8172)*2;}
if($xx > 250730){$estsplit=int($xx*0.45-15694)*2;}

if($est > 972){$soli=int($est*0.055);}
if($estsplit >1944){
     $solisplit=int($estsplit*0.055); my $test= int(($estsplit-1944)*0.2);
       if ($solisplit > $test){$solisplit=$test;}
  }
my $netto=$x-$est-$soli; my $nettosplit=$x-$estsplit-$solisplit;

print"\n             \t   - (ohne Kirche/Kind)  Steuer 2010 -    \n\n";
print"                         \tGrundtarif \t Splitting \n\n";
print"                    ESt: \t$est       \t $estsplit  \n\n";
print"     (* Vorbehalt) SolZ: \t$soli      \t $solisplit \n\n";
print"                  ----------------------------------------- \n";
print"                  Netto: \t$netto     \t $nettosplit \n";
print"\n\n * if(Verfassungsgericht_Urteil eq \"widerrechtlich\") {automatische Erstattung}\n\n";
}],


#_______________________________________________________________________
'xxo' => [
"xxo \t\t Game : TicTacToe",
sub
{
  print "What's your name Player1?: ";
  my $player1 = <STDIN>;
  chomp $player1;
  print "\nWhat's your name Player2?: ";
  my $player2 = <STDIN>;
  chomp $player2;

  if ($player1 eq $player2) {
    $player2 = $player2."2";
    }


  my @field = ("_", "_", "_", "_", "_", "_", "_", "_", "_", "_");
  my @valids = (1, 2, 3, 4, 5, 6, 7, 8, 9);
  my $name = $player1;
  my $roundcount = 1;
  my $choose;
  my $stone = 'x';
  my $win = 0;
  my $othername = $player2;
  my $tmpname;
  my $stone2 = 'o';
  my $tmpstone;
  my $valid; 

  system("clear");
  while ($roundcount <= 9 ) {

   
   print "|$field[7]|$field[8]|$field[9]|    |7|8|9|\n";
   print "|$field[4]|$field[5]|$field[6]|    |4|5|6|\n";
   print "|$field[1]|$field[2]|$field[3]|    |1|2|3|\n";
   print "\n$name your turn\n";
   print "In which field do you want to set? ";
   $choose = <STDIN>; 
   chomp $choose;
   
   if(grep $_ eq $choose, @valids) {
     $valid = 1; }
   else { 
     $valid = 0; } 

   if ($field[$choose] ne '_') {
     if ($field[$choose] eq $stone) {
           print "you had set here before\n";
           }
   else {
           print "$othername had set here before\n";
           }
         $valid = 0;

        }
   else {
     $field[$choose] = $stone;
         }
        
    if ($field[1] eq $stone and $field[2] eq $stone and $field[3] eq $stone) {
             $win = 1; }
    elsif ($field[4] eq $stone and $field[5] eq $stone and $field[6] eq $stone) {
             $win = 1; }
    elsif ($field[7] eq $stone and $field[8] eq $stone and $field[9] eq $stone) {
             $win = 1; }
    elsif ($field[1] eq $stone and $field[4] eq $stone and $field[7] eq $stone) {
             $win = 1; }
    elsif ($field[2] eq $stone and $field[5] eq $stone and $field[8] eq $stone) {
             $win = 1; }
    elsif ($field[3] eq $stone and $field[6] eq $stone and $field[9] eq $stone) {
             $win = 1; }
    elsif ($field[1] eq $stone and $field[5] eq $stone and $field[9] eq $stone) {
             $win = 1; }
    elsif ($field[3] eq $stone and $field[5] eq $stone and $field[7] eq $stone) {
             $win = 1; } 
                        
        if ($win eq 1) {
      last;
    }
         
    $roundcount++;
                        
        if ( $valid eq 1) {
        $tmpname = $name;
        $name = $othername;
        $othername = $tmpname;
        $tmpstone = $stone;
        $stone = $stone2;
        $stone2 = $tmpstone;
        system("clear");
        }
        else {
          $roundcount--; }
        
  }
        
  print "|$field[7]|$field[8]|$field[9]|    |7|8|9|\n";
  print "|$field[4]|$field[5]|$field[6]|    |4|5|6|\n";
  print "|$field[1]|$field[2]|$field[3]|    |1|2|3|\n";
  if ($win eq 1) {
        print "Congratulations $name you win";
        }
  else {
        print "--->DRAW<---";
        }
}],
#_______________________________________________________________________
'timer=i' => [
"timer <time> \t\tlet Speaker beep after userdefined minutes",
sub {
  my $time = int(shift);
  my $timer = $time * 60;
  my $sleepy = $timer / 20;
  my $pro = 5;
  my $i = 1;
  init_progress;
  while ($i < 21) {
    update_progress $pro;
    $i += 1;
    $pro += 5;
    sleep($sleepy);
    }
  print "\n\a\a\a\a\a\a\a";
}],
#_______________________________________________________________________
'export=s,expdeparse:s' => [
"export <optionname> [--expdeparse '<B::Deparse Options>']\t\texport one option of this script (--expdeparse=1 force B::Deparse)",
sub {
  my $option=shift || '';
  my $depopts=shift || '';

  # normiere options_name
  $option=~s/^\-+//;
  $option=~s/=.*$//;
  $option=~s/\s.*$//;
  $option=~s/^\s+//;

  # finde hash_name zur Option
  my $name='';
  for my $key (keys(%commands))
  {
    if($key=~m!(?:^|,)\Q$option\E(?:=|:|,|$)!)
    {
      $name=$key;
      last;
    }
  }

  unless($name)
  {
    warn("NO valid Option: $option\n");
    HELP();
    return;
  }


  #hilfe holen
  my $help=$commands{$name}->[0];
  $help=~s/\t\t/\\n\\t/;

  # script lesen
  my $code_else='';
  {
    my $pos=tell(DATA);
    seek(DATA,0,0);
    local $/=undef;
    $code_else=<DATA>;
    seek(DATA,$pos,0);
  }

  my $code='';
  # code heraus schneiden
  if($depopts ne '')
  {
    $depopts='' if($depopts eq '1');
    my @opts=();
    @opts=split(/\s+/,$depopts) if($depopts);
    use B::Deparse;
    $code = B::Deparse->new(@opts)->coderef2text($commands{$name}->[1]);
  }
  else
  {
    ($code)=$code_else=~m#'\Q$name\E'\s*=>\s*\[\s*".+?"\s*,\s*sub\s*\{(.+?)\n\s*\}(?:\s*,[^\]]+)?\s*\]\s*,#s;
    $code="{\n$code\n}";
  }

  # Optionen umwandeln
  my @opt_list=split(/\s*,\s*/,$name);
  my @ref_list=();
  my $first=shift(@opt_list);
  if($first=~/=|:/)
  { $first='unshift(@opts,shift(@ARGV));'; }
  else
  { $first='unshift(@opts,1);'; }
  for(0..$#opt_list)
  {
    $opt_list[$_] =qq('$opt_list[$_]').' => \$opts['.$_.']';
    push(@ref_list,'undef');
  }
  push(@opt_list,q('help' => sub{ HELP(); }));

  # startcode erzeugen
  my $scode=sprintf(<<'EOC',join(', ',@ref_list),join(", ",@opt_list),$first,$option,$help,$option,$code);
my @opts=(%s);

my $ok=GetOptions(%s);

%s

HELP() if(@ARGV);
HELP() unless($ok);

%s(@opts);

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub HELP
{
  print "usage: %s\n";
  exit(0);
}

sub %s
%s


EOC
  # history ändern
  my $time=localtime();
  $code_else=~s!# History:(?:\n#[^\n]+)*!# History:\n# AUTOEXPORT - $time - export of $option\n!;
  # code einfügen
  # von <-- please don't touch this
  # bis # FUNCTIONS #
  # wird alles gelöscht
  $code_else=~s!# <-- please don't touch this.+\n#+\n# FUNCTIONS #+\n#+\n!$scode!s;
  # unwichtige Funktionen entfernen
  $code_else=~s!#+\n# BUILD IN FUNCTIONS #+\n#+\n.+$!__END__!s;

  # alles in Datei schreiben
  open(my $fh, '>', "$option.pl") or die "ERROR open $option.pl ($!)";
  print $fh $code_else;
  close($fh);
}],

# <-- don't touch this

########################################################################
########################################################################
);

for(keys(%commands))
{
  my $opt=$_;
  my $cmdref=$commands{$_}[1];
  my $runn_mod='runn last';
  $runn_mod=lc($commands{$_}[2]) if(exists($commands{$_}[2]));
  my @olist=split(/\s*,\s*/s,$opt);

  if($runn_mod eq 'runn now')
  {
    for(@olist)
    { $opts{$_}=sub{ $cmdref->(pop(@_)); } }
  }
  elsif($runn_mod eq 'runn first')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,1); }
    }
  }
  elsif($runn_mod eq 'runn last')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,0); }
    }
  }
  else
  { die(qq#Can't interpret runn modifier "$runn_mod" \n#); }
}
my $ok=GetOptions(%opts);

HELP(@ARGV) if(@ARGV);
HELP(0) unless($ok);

for my $cmd (@runn)
{
  my $name=shift(@$cmd);
  $commands{$name}->[1]->(@$cmd);
}

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub stuff {
  my $url=shift;
  my $agent="Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.9.0.18) EierlegendeMilchSau/1.0.0";
  my $cookie = HTTP::Cookies->new;

  my $req = HTTP::Request->new(GET => $url);
  $req->header('Referer', '');
  $req->header('Accept', 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8');
  $req->header('Accept-Language', 'de-de,de;q=0.8,en-us;q=0.5,en;q=0.3');
  $req->header('Accept-Charset', 'ISO-8859-1,utf-8;q=0.7,*;q=0.7');
  $req->header('Keep-Alive', '115');
  $req->header('Cache-Control', 'max-age=0');
  my $browser = LWP::UserAgent->new;
  $browser -> agent($agent);
  $browser -> cookie_jar($cookie);
  my $res = $browser->request($req);
  my $stuff = $res->content;
  return ($stuff);
}# end sub stuff

########################################################################
# BUILD IN FUNCTIONS ###################################################
########################################################################

sub add_cmd
{
  my $name=shift;
  my $opt=shift;
  my $pos=shift || 0;
  my $first=shift || 0;
  for my $ref (@runn)
  {
    if($ref->[0] eq  $name)
    {
      $ref->[$pos+1]=$opt;
      return;
    }
  }

  if($first)
  { unshift(@runn,[$name,$opt]); }
  else
  { push(@runn,[$name,$opt]); }
}

sub HELP{
  my @errors=@_;

  my @list=();
  my $length_first;
  my $length_second;
  for my $cmd (sort keys(%commands))
  {
    $length_first=length($cmd) if(!defined($length_first) || $length_first<length($cmd));
    my ($cmdtxt,$desctxt)=split("\t\t",$commands{$cmd}->[0],2);
    $desctxt='' unless($desctxt);
    $cmdtxt='' unless($cmdtxt);
    $length_second=length($cmdtxt) if(!defined($length_second) || $length_second<length($cmdtxt));
    push(@list,[$cmd,$cmdtxt,$desctxt]);
  }

  my $oh=\*STDOUT;
  $oh=\*STDERR if @errors;

  if($errors[0])
  {
    for(@errors)
    { print $oh "Unknown option: $_\n"; }
  }

  print $oh "usage: $0 <parameters>\n\n";
  print $oh "parameters:\n";

  for(@list)
  { printf $oh "  %-${length_first}s => --%-${length_second}s %s\n", @$_; }

  print $oh "\n";
  exit(@errors?1:0);
}

__END__

Kommt schon die 1000 Zeilen schaffen wir noch :)

mfg
conray
Last edited: 2010-05-06 11:20:53 +0200 (CEST)

+2 replies

conray

2010-08-25 14:48

User since
2010-02-19
52 Artikel
BenutzerIn
[default_avatar]

Mal wieder was kleines.
added cat

Code (perl): (dl )

#!/usr/bin/perl
use strict;
use warnings;

# History:
# conray  - 19.02.2010 : 19:31 UTC - initial version with ping (-ping)
# betterworld - 19.02.2010 : 19:44 UTC - minor changes
# esskar  - 19.02.2010 : 20:27 UTC - changes on ping, and dump myself command (-dump)
# topeg  - 19.02.2010 : 00:02 UTC - addded mirror
# Kalle - 01.03.2010 - added technology assimilation automation
# conray - 02.02.2010 21:07 - added Helpfunktion (-help) and changes on Ping-Parameter
# conray - 03.02.2010 19:28 - added Password-Generator (-pwgen)
# conray - 08.03.2010 21:35 - added print location (-whereami)
# steferbo - 08.03.2010 23:10 - added get country from ip (-get_country)
# topeg - 09.03.2010 23:46 - changed to GetOpt::Long, adapt assimilate ping, pwgen and get_country, added dummy (--dummy), added truemirror (--truemirror <file|->)
# steferbo - 12.03.2010 22:30 - added steuern2010
# topeg - 16.03.2010 01:00 - added echo (--echo <txt>), added export (--export <option>), edit steuern2010, edit assimilate
# topeg - 16.03.2010 22:20 - edit export now you can choose to use B::Deparse or a regular expression to grep the code.
# conray - 23.04.2010 00:58 UTC added xxo - TicTacToe game
# conray - 05.05.2010 20:44 UTC added timer - let Speaker beep after userdefined minutes
# conray - 25.08.2010 14:42 UTC added cat - print file to STDOUT

use Getopt::Long;
use FindBin;
use Net::Ping;
use LWP::UserAgent;
use HTTP::Cookies;
use File::Basename;
use ProgressBar::Stack;

# <-- please don't touch this

#EierlegendeWollMilchSau.pl
my %opts=();
my @runn=();
my %commands=();
%commands=(
########################################################################
########################################################################

#_______________________________________________________________________
'dummy' => [
"dummy\t\tDoing nothing!",
sub {
  # empty.
}],
#_______________________________________________________________________
'echo=s,echannel=s,enonewline' => [
"echo <sting> [--echannel <STDOUT|STDERR|file>] [--enonewline]\t\tprint <string> to STDOUT|STDERR|file",
sub {
  my ($txt,$channel,$nnl)=@_;
  $txt='' unless(defined($txt));

  my $fh=\*STDOUT;
  if($channel)
  {
    if($channel eq 'STDERR')
    { $fh=\*STDERR; }
    elsif($channel ne 'STDOUT')
    { open($fh,'>',$channel) or die("ERROR open: $channel ($!)\n"); }
  }

  print $fh $txt,$nnl?'':"\n";
}],

#_______________________________________________________________________
'help|h' => [
"help\t\tprint out this usagetext",
sub{
  HELP();
},
'runn now'],

#_______________________________________________________________________
'ping=s,range=i' => [
"ping <ip> [--range=<range>]\t\ttrys to ping an ip or an range of ip addresses.",
sub
{
  my ($ip,$till) = @_;
  my @r = split(/\./, $ip);

  $till=$r[3] unless(defined($till));

  my $until = $till + 1;
  while ($r[3] < $until )
  {
    $ip = join '.', @r;
    my $ping = Net::Ping->new('icmp', 1, 64 );
    print "$ip " . ($ping->ping($ip) ? 'online' : 'offline') . "\n";
    $r[3]++;
  }
}],

#_______________________________________________________________________
'dump' => [
"dump\t\tdumps itself to STDOUT",
sub
{
  my $path = "$FindBin::Bin/$FindBin::Script";
  open(my $myself, "< $path") or die "Unable to open myself ($path): $!";
  while(<$myself>) { print $_; }
  close $myself;
}],

#_______________________________________________________________________
'devil' => [
"devil\t\tDon't try that",
sub
{
  print "So long, and thanks for all the fish.\n";
  unlink $0 or die "Will not stop :'-(\n";
}],

#_______________________________________________________________________
'mirror=s' => [
"mirror <file|->\t\tmirror file or STDIN",
sub
{
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  chomp($_) && print reverse($_)."\n" while(<$fh>);
  close($fh);
}],

#_______________________________________________________________________
'truemirror=s' => [
"truemirror <file|->\t\tmirror file or STDIN",
sub
{
  my $fh=\*STDIN;
  my $file=shift;
  open($fh,'<',$file) || die("ERROR open $file ($!)") if($file && $file ne '-');
  my @lines=();
  my $length;
  while (my $line=<$fh>)
  {
    $length=length($line) if(!defined($length) || $length<length($line));
    chomp($line);
    $line=reverse($line);
    $line=~y/()[]{}\\\/`´<>/)(][}{\/\\´`></;
    push(@lines,$line);
  }
  printf("%${length}s\n",$_) for(@lines);
  close($fh);
}],

#_______________________________________________________________________
'assimilate=s,asshelptext=s' => [
"assimilate newparam.pl [--asshelptext <helptext>]\t\tassimilate more perl code into this script",
sub
{
  my $newtechsource=shift;
  my $helptext=shift || "assimilated weird stuff";
  my $borgtechnology;
  my $assimilationspace;
  my $newtechnology;
  my ($newcmdname)=split(/\./,$newtechsource,0);
  $newcmdname=~y/=|!?//d;
  $newcmdname=~s/\s+/_/s;
  my ($borgbase,$borgpath)=fileparse($0);
  my $newborgtechnology="${borgpath}Neue$borgbase";
  if (open($borgtechnology,'<',$0)) {
    if (open($assimilationspace,'>',$newborgtechnology)) {
      if (open($newtechnology,'<',$newtechsource)) {
        while(<$borgtechnology>) {
          if (/^# <-- don't touch this/) {
             my $thisline=$_;
             print "Assimiliere neue Technologie...\n";
             print $assimilationspace qq!
#_______________________________________________________________________
'$newcmdname' => [
"$newcmdname\\t\\t $helptext",
sub {
!;
             while(<$newtechnology>) {
               next if (/^#!|^use strict;|^use warnings;/);
               print $assimilationspace $_;
             }
             close($newtechnology);
             print $assimilationspace qq!
},
'runn now'],

$thisline!;
          }
          else {
            print $assimilationspace $_;
          }
        }
        close($borgtechnology);
        if (close($assimilationspace)) {
          print "Widerstand war zwecklos!\nNeue Technologie einsetzbar: Neue$borgbase --$newcmdname\n";
        }
        else {
          print "Aktivierungssequenz ungültig. Assimilation abgebrochen.\n";
        }
      }
      else {
        print "Neue Technologie kann nicht assimiliert werden. Abbruch der Assimilation\n";
      }
    }
    else {
      print "Fluktuation im temporären Raum-/Zeitgefüge. Abbruch der Assimilation.\n";
    }
  }
  else {
    print "Wo sind wir ? Es ist so....leise. Bring uns nach Hause!\n";
  }
}],

#_______________________________________________________________________
'pwgen=i' => [
"pwgen\t\tgenerates a (secure) password",
sub
{
  my $input=shift;
  unless($input)
  {
    print "How much positions your password should have?\n";
    print "Note: Secure passwords have 10 positions as minimum \n";
    $input=<STDIN>;
    chomp $input;
  }
  $input=~s/[^\-\d].+$//;
  $input=abs($input);

  my @bletters = ("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z");
  my @sletters = ("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z");
  my @numbers = ("1", "2", "3", "4", "5", "6", "7", "8", "9", "0");
  my @special = ("!", "\.", "\$", "\%", "\&", "?", "\/", "\\", "\,", "-", "_", "\#", "\*", ":", "(", ")", "=", "+", "<", "§", "[", "]", "\;");

  my $pw='';
  while (length($pw) != $input) {
     my $n1 = int(rand(26));
     my $n2 = int(rand(26));
     my $n3 = int(rand(10));
     my $n4 = int(rand(23));
     my $z = int(rand(4));
     if ($z == 0) {
        $pw = $pw . $bletters[$n1]; }
     elsif ($z == 1) {
        $pw = $pw . $sletters[$n2]; }
     elsif ($z == 2) {
        $pw = $pw . $numbers[$n3]; }
     elsif ($z == 3) {
        $pw = $pw . $special[$n4]; }
     else {
        print "There is bug";
        exit; }
     }
  print "The generated Password is: $pw \n";
}],

#_______________________________________________________________________
'whereami' => [
"whereami\t\tprint out the filelocation",
sub
{
  print __FILE__."\n";
}],

#_______________________________________________________________________
'get_country=s' => [
"get_country <ip>\t\tsingle-host 32bit decimal",
sub
{
  my $ip = shift;
  my $line=""; my $country=""; my $out="IP: $ip is non-registered";
  my $whois="http://www.utrace.de/whois/";
  my $hol=$whois.$ip;
  my $html=stuff($hol);
    $html =~ s/<([^>]|\n)*>//mig;
    $html =~ s/&nbsp;//mig;
    (my @text)=split(/\n/,$html);
        foreach $line (@text){
                      if( $line =~ /country:/ig ){
                      $line =~ s/\s//ig;
      (my $nix, $country)=split(/:/,$line);
                      $out="IP: $ip has country-code: $country";
                      goto ELMS;
          } # end if
         } # end foeach
  ELMS:
  print $out;
}],


#_______________________________________________________________________
'steuer2010=s' => [
"steuer2010 <einkommen>\t\tSteuer2010 - ESt und SolZ ",
sub
{
my $x=shift;

unless(defined($x))
{
  print "\n\nzu versteuerndes Einkommen: ";
  chomp ($x = <STDIN>);
}

my $est=0;my $soli=0;my $estsplit=0; my $solisplit=0;
if($x > 8004 && $x < 13470){$est=int((912.17*($x -8004)/10000+1400)*($x- 8004)/10000);}
if($x > 13469 && $x < 52882){$est=int((228.74*($x -13469)/10000+2397)*($x-13469)/10000+1038);}
if($x > 52881 && $x < 250731){$est=int($x*0.42-8172);}
if($x > 250730){$est=int($x*0.45-15694);}

my $xx=$x/2;
if($xx > 8004 && $xx < 13470){$estsplit=int((912.17*($xx -8004)/10000+1400)*($xx- 8004)/10000)*2;}
if($xx > 13469 && $xx < 52882){$estsplit=int((228.74*($xx -13469)/10000+2397)*($xx-13469)/10000+1038)*2;}
if($xx > 52881 && $xx < 250731){$estsplit=int($xx*0.42-8172)*2;}
if($xx > 250730){$estsplit=int($xx*0.45-15694)*2;}

if($est > 972){$soli=int($est*0.055);}
if($estsplit >1944){
     $solisplit=int($estsplit*0.055); my $test= int(($estsplit-1944)*0.2);
       if ($solisplit > $test){$solisplit=$test;}
  }
my $netto=$x-$est-$soli; my $nettosplit=$x-$estsplit-$solisplit;

print"\n             \t   - (ohne Kirche/Kind)  Steuer 2010 -    \n\n";
print"                         \tGrundtarif \t Splitting \n\n";
print"                    ESt: \t$est       \t $estsplit  \n\n";
print"     (* Vorbehalt) SolZ: \t$soli      \t $solisplit \n\n";
print"                  ----------------------------------------- \n";
print"                  Netto: \t$netto     \t $nettosplit \n";
print"\n\n * if(Verfassungsgericht_Urteil eq \"widerrechtlich\") {automatische Erstattung}\n\n";
}],


#_______________________________________________________________________
'xxo' => [
"xxo \t\t Game : TicTacToe",
sub
{
  print "What's your name Player1?: ";
  my $player1 = <STDIN>;
  chomp $player1;
  print "\nWhat's your name Player2?: ";
  my $player2 = <STDIN>;
  chomp $player2;

  if ($player1 eq $player2) {
    $player2 = $player2."2";
    }


  my @field = ("_", "_", "_", "_", "_", "_", "_", "_", "_", "_");
  my @valids = (1, 2, 3, 4, 5, 6, 7, 8, 9);
  my $name = $player1;
  my $roundcount = 1;
  my $choose;
  my $stone = 'x';
  my $win = 0;
  my $othername = $player2;
  my $tmpname;
  my $stone2 = 'o';
  my $tmpstone;
  my $valid; 

  system("clear");
  while ($roundcount <= 9 ) {

   
   print "|$field[7]|$field[8]|$field[9]|    |7|8|9|\n";
   print "|$field[4]|$field[5]|$field[6]|    |4|5|6|\n";
   print "|$field[1]|$field[2]|$field[3]|    |1|2|3|\n";
   print "\n$name your turn\n";
   print "In which field do you want to set? ";
   $choose = <STDIN>; 
   chomp $choose;
   
   if(grep $_ eq $choose, @valids) {
     $valid = 1; }
   else { 
     $valid = 0; } 

   if ($field[$choose] ne '_') {
     if ($field[$choose] eq $stone) {
           print "you had set here before\n";
           }
   else {
           print "$othername had set here before\n";
           }
         $valid = 0;

        }
   else {
     $field[$choose] = $stone;
         }
        
    if ($field[1] eq $stone and $field[2] eq $stone and $field[3] eq $stone) {
             $win = 1; }
    elsif ($field[4] eq $stone and $field[5] eq $stone and $field[6] eq $stone) {
             $win = 1; }
    elsif ($field[7] eq $stone and $field[8] eq $stone and $field[9] eq $stone) {
             $win = 1; }
    elsif ($field[1] eq $stone and $field[4] eq $stone and $field[7] eq $stone) {
             $win = 1; }
    elsif ($field[2] eq $stone and $field[5] eq $stone and $field[8] eq $stone) {
             $win = 1; }
    elsif ($field[3] eq $stone and $field[6] eq $stone and $field[9] eq $stone) {
             $win = 1; }
    elsif ($field[1] eq $stone and $field[5] eq $stone and $field[9] eq $stone) {
             $win = 1; }
    elsif ($field[3] eq $stone and $field[5] eq $stone and $field[7] eq $stone) {
             $win = 1; } 
                        
        if ($win eq 1) {
      last;
    }
         
    $roundcount++;
                        
        if ( $valid eq 1) {
        $tmpname = $name;
        $name = $othername;
        $othername = $tmpname;
        $tmpstone = $stone;
        $stone = $stone2;
        $stone2 = $tmpstone;
        system("clear");
        }
        else {
          $roundcount--; }
        
  }
        
  print "|$field[7]|$field[8]|$field[9]|    |7|8|9|\n";
  print "|$field[4]|$field[5]|$field[6]|    |4|5|6|\n";
  print "|$field[1]|$field[2]|$field[3]|    |1|2|3|\n";
  if ($win eq 1) {
        print "Congratulations $name you win";
        }
  else {
        print "--->DRAW<---";
        }
}],
#_______________________________________________________________________
'timer=i' => [
"timer <time> \t\tlet Speaker beep after userdefined minutes",
sub {
  my $time = int(shift);
  my $timer = $time * 60;
  my $sleepy = $timer / 20;
  my $pro = 5;
  my $i = 1;
  init_progress;
  while ($i < 21) {
    update_progress $pro;
    $i += 1;
    $pro += 5;
    sleep($sleepy);
    }
  print "\n\a\a\a\a\a\a\a";
}],
#_______________________________________________________________________
'cat=s' => ["cat <file>\t\tprint file to STDOUT",

sub {
  my $file = shift;
  open(DATA, $file) or die "Can't open $file: $!\n";
  while (<DATA>)
  {
      print;
  }
  close(DATA);
  print "\n";
}],
#_______________________________________________________________________
'export=s,expdeparse:s' => [
"export <optionname> [--expdeparse '<B::Deparse Options>']\t\texport one option of this script (--expdeparse=1 force B::Deparse)",
sub {
  my $option=shift || '';
  my $depopts=shift || '';

  # normiere options_name
  $option=~s/^\-+//;
  $option=~s/=.*$//;
  $option=~s/\s.*$//;
  $option=~s/^\s+//;

  # finde hash_name zur Option
  my $name='';
  for my $key (keys(%commands))
  {
    if($key=~m!(?:^|,)\Q$option\E(?:=|:|,|$)!)
    {
      $name=$key;
      last;
    }
  }

  unless($name)
  {
    warn("NO valid Option: $option\n");
    HELP();
    return;
  }


  #hilfe holen
  my $help=$commands{$name}->[0];
  $help=~s/\t\t/\\n\\t/;

  # script lesen
  my $code_else='';
  {
    my $pos=tell(DATA);
    seek(DATA,0,0);
    local $/=undef;
    $code_else=<DATA>;
    seek(DATA,$pos,0);
  }

  my $code='';
  # code heraus schneiden
  if($depopts ne '')
  {
    $depopts='' if($depopts eq '1');
    my @opts=();
    @opts=split(/\s+/,$depopts) if($depopts);
    use B::Deparse;
    $code = B::Deparse->new(@opts)->coderef2text($commands{$name}->[1]);
  }
  else
  {
    ($code)=$code_else=~m#'\Q$name\E'\s*=>\s*\[\s*".+?"\s*,\s*sub\s*\{(.+?)\n\s*\}(?:\s*,[^\]]+)?\s*\]\s*,#s;
    $code="{\n$code\n}";
  }

  # Optionen umwandeln
  my @opt_list=split(/\s*,\s*/,$name);
  my @ref_list=();
  my $first=shift(@opt_list);
  if($first=~/=|:/)
  { $first='unshift(@opts,shift(@ARGV));'; }
  else
  { $first='unshift(@opts,1);'; }
  for(0..$#opt_list)
  {
    $opt_list[$_] =qq('$opt_list[$_]').' => \$opts['.$_.']';
    push(@ref_list,'undef');
  }
  push(@opt_list,q('help' => sub{ HELP(); }));

  # startcode erzeugen
  my $scode=sprintf(<<'EOC',join(', ',@ref_list),join(", ",@opt_list),$first,$option,$help,$option,$code);
my @opts=(%s);

my $ok=GetOptions(%s);

%s

HELP() if(@ARGV);
HELP() unless($ok);

%s(@opts);

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub HELP
{
  print "usage: %s\n";
  exit(0);
}

sub %s
%s


EOC
  # history ändern
  my $time=localtime();
  $code_else=~s!# History:(?:\n#[^\n]+)*!# History:\n# AUTOEXPORT - $time - export of $option\n!;
  # code einfügen
  # von <-- please don't touch this
  # bis # FUNCTIONS #
  # wird alles gelöscht
  $code_else=~s!# <-- please don't touch this.+\n#+\n# FUNCTIONS #+\n#+\n!$scode!s;
  # unwichtige Funktionen entfernen
  $code_else=~s!#+\n# BUILD IN FUNCTIONS #+\n#+\n.+$!__END__!s;

  # alles in Datei schreiben
  open(my $fh, '>', "$option.pl") or die "ERROR open $option.pl ($!)";
  print $fh $code_else;
  close($fh);
}],

# <-- don't touch this

########################################################################
########################################################################
);

for(keys(%commands))
{
  my $opt=$_;
  my $cmdref=$commands{$_}[1];
  my $runn_mod='runn last';
  $runn_mod=lc($commands{$_}[2]) if(exists($commands{$_}[2]));
  my @olist=split(/\s*,\s*/s,$opt);

  if($runn_mod eq 'runn now')
  {
    for(@olist)
    { $opts{$_}=sub{ $cmdref->(pop(@_)); } }
  }
  elsif($runn_mod eq 'runn first')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,1); }
    }
  }
  elsif($runn_mod eq 'runn last')
  {
    for my $pos (0..$#olist)
    {
      die("no option in $opt position $pos\n") unless($olist[$pos]);
      $opts{$olist[$pos]}=sub{ add_cmd($opt,pop(@_),$pos,0); }
    }
  }
  else
  { die(qq#Can't interpret runn modifier "$runn_mod" \n#); }
}
my $ok=GetOptions(%opts);

HELP(@ARGV) if(@ARGV);
HELP(0) unless($ok);

for my $cmd (@runn)
{
  my $name=shift(@$cmd);
  $commands{$name}->[1]->(@$cmd);
}

########################################################################
# FUNCTIONS ############################################################
########################################################################

sub stuff {
  my $url=shift;
  my $agent="Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.9.0.18) EierlegendeMilchSau/1.0.0";
  my $cookie = HTTP::Cookies->new;

  my $req = HTTP::Request->new(GET => $url);
  $req->header('Referer', '');
  $req->header('Accept', 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8');
  $req->header('Accept-Language', 'de-de,de;q=0.8,en-us;q=0.5,en;q=0.3');
  $req->header('Accept-Charset', 'ISO-8859-1,utf-8;q=0.7,*;q=0.7');
  $req->header('Keep-Alive', '115');
  $req->header('Cache-Control', 'max-age=0');
  my $browser = LWP::UserAgent->new;
  $browser -> agent($agent);
  $browser -> cookie_jar($cookie);
  my $res = $browser->request($req);
  my $stuff = $res->content;
  return ($stuff);
}# end sub stuff

########################################################################
# BUILD IN FUNCTIONS ###################################################
########################################################################

sub add_cmd
{
  my $name=shift;
  my $opt=shift;
  my $pos=shift || 0;
  my $first=shift || 0;
  for my $ref (@runn)
  {
    if($ref->[0] eq  $name)
    {
      $ref->[$pos+1]=$opt;
      return;
    }
  }

  if($first)
  { unshift(@runn,[$name,$opt]); }
  else
  { push(@runn,[$name,$opt]); }
}

sub HELP{
  my @errors=@_;

  my @list=();
  my $length_first;
  my $length_second;
  for my $cmd (sort keys(%commands))
  {
    $length_first=length($cmd) if(!defined($length_first) || $length_first<length($cmd));
    my ($cmdtxt,$desctxt)=split("\t\t",$commands{$cmd}->[0],2);
    $desctxt='' unless($desctxt);
    $cmdtxt='' unless($cmdtxt);
    $length_second=length($cmdtxt) if(!defined($length_second) || $length_second<length($cmdtxt));
    push(@list,[$cmd,$cmdtxt,$desctxt]);
  }

  my $oh=\*STDOUT;
  $oh=\*STDERR if @errors;

  if($errors[0])
  {
    for(@errors)
    { print $oh "Unknown option: $_\n"; }
  }

  print $oh "usage: $0 <parameters>\n\n";
  print $oh "parameters:\n";

  for(@list)
  { printf $oh "  %-${length_first}s => --%-${length_second}s %s\n", @$_; }

  print $oh "\n";
  exit(@errors?1:0);
}

__END__

mfg
conray

Dubu

2010-08-27 00:39
User since
2003-08-04
2145 Artikel
ModeratorIn + EditorIn
IMHO ist 'cat' besser geschrieben als
Code (perl): (dl )

1 2 3

sub { print <>; }
- Es funktioniert mit mehr als einem Dateinamen.
- Es funktioniert auch mit Eingabe von STDIN.
- Es funktioniert auch mit '-' als Dateiname (für STDIN).
- Es ist kürzer und damit weniger fehleranfällig. ;-)
Und ansonsten: Ein lexikalisches Filehandle wäre dem globalen DATEI vorzuziehen und die while-Schleife kann man sich sparen (print <DATEI> funktioniert).

View all threads created 2010-02-19 20:31.