#!/usr/bin/env perl

use warnings;
use strict;

use DBI;

# ===== Config:

my $dbfile = "trac.db";
my $milestone = "7.4.1";
my $test = 0;

# ===== Code:

my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","", {});

my %emailof;
my %ticketsfor;

sub getUserAddress {
    my $sth = $dbh->prepare("SELECT sid, value FROM session_attribute WHERE name = 'email'");
    $sth->execute();
    while (my $result = $sth->fetchrow_hashref("NAME_lc")) {
        my $username = $result->{sid};
        my $email    = $result->{value};
        if (defined($emailof{$username})) {
            die "Two e-mail addresses found for $username";
        }
        if ($email =~ /@/) {
            $emailof{$username} = $email;
        }
        else {
            # warn "The e-mail address $email for $username contains no @";
        }
    }
    $sth->finish;
}

sub doTickets {
    my $sth = $dbh->prepare("SELECT id, summary, reporter, cc FROM ticket WHERE milestone = ? AND status = 'new'");
    $sth->execute($milestone);
    while (my $result = $sth->fetchrow_hashref("NAME_lc")) {
        my $ticket   = $result->{id};
        my $title    = $result->{summary};
        my $reporter = $result->{reporter};
        my $cc       = $result->{cc};
        my %addresses;
        my $address_added;
        for my $who ($reporter, split /[ ,]+/, $cc) {
            $address_added = 0;
            if ($who =~ /@/) {
                $addresses{$who} = 1;
                $address_added = 1;
            }
            if (defined($emailof{$who})) {
                $addresses{$emailof{$who}} = 1;
                $address_added = 1;
            }
            if ($who ne "nobody" && $address_added eq 0) {
                # warn "No address found for $who";
            }
        }
        for my $address (keys(%addresses)) {
            $ticketsfor{$address}{$ticket}{"title"} = $title;
        }
    }
    $sth->finish;
}

sub doEmails {
    for my $email (sort (keys %ticketsfor)) {
        if ($test ne 0) {
            open FH, ">&STDOUT";
        }
        else {
            open(FH, '|-', 'mail', '-s', 'GHC bugs', '-a', 'From: glasgow-haskell-bugs@haskell.org', $email) or die "Running mail failed: $!";
        }
        print FH <<'EOF';

Hello,

You are receiving this mail because you are the reporter, or on the CC
list, for one or more GHC tickets that are automatically having their
priority reduced due to our post-release ticket handling policy:
    http://ghc.haskell.org/trac/ghc/wiki/WorkingConventions/BugTracker#Remilestoningticketsafterarelease

The list of tickets for which you are the reporter or on the CC list is
given below. If any of these are causing problems for you, please let us
know on glasgow-haskell-bugs@haskell.org and we'll look at raising the
priority.

Better still, if you are able to make any progress on any of the tickets
yourself (whether that be actually fixing the bug, or just making it
easier for someone else to - for example, by making a small,
self-contained test-case), then that would be a great help. We at GHC HQ
have limited resources, so if anything is waiting for us to make
progress then it can be waiting a long time!
EOF
        for my $ticket (sort {$a <=> $b} (keys %{$ticketsfor{$email}})) {
            my $title = $ticketsfor{$email}{$ticket}{"title"};
            print FH "\n";
            print FH "#$ticket $title:\n";
            print FH "    http://ghc.haskell.org/trac/ghc/ticket/$ticket\n";
        }
        print FH <<'EOF';

--
The GHC Team
http://www.haskell.org/ghc/
EOF
        close FH or die "Close failed: $!";
    }
}

&getUserAddress();
&doTickets();
&doEmails();


#!/usr/bin/env perl

use FindBin;

%DirCount = ();
%ModCount = ();
%DirComments = ();
%ModComments = ();

my $binPath = $FindBin::Bin;

foreach $f ( @ARGV ) {

    if ( $f =~ /\.lhs$/ ) {
        open(INF, "$binPath/../../inplace/lib/unlit $f - |") || die "Couldn't unlit $f!\n";
    } else {
        open(INF, "< $f") || die "Couldn't open $f!\n";
    }
    $cnt = 0;
    while (<INF>) {
        s/--.*//;
        s/{-.*-}//;
        s/\/\/.*//;
        next if /^\s*$/;
        $cnt++;
    }
    close(INF);

    $f_wc = `wc $f`; die "wc failed: $f\n" if $? != 0;
    if ( $f_wc =~ /\s*(\d+)\s*(\d+)\s*(\d+)/ ) {
        $comments = $1 - $cnt;
    } else {
        die "Can't grok wc format: $f_wc";
    }

    if ( $f =~ /(.*)\/(.*)/ ) {
        local($dir) = $1;
        local($mod) = $2;
        $DirCount{$dir} += $cnt;
        $ModCount{$mod} += $cnt;
        $DirComments{$dir} += $comments;
        $ModComments{$mod} += $comments;
    } else {
        print STDERR "not counted in a directory: $f\n";
        $ModCount{$f} += $cnt;
        $ModComments{$f} += $comments;
    }
}

# print the info
$tot = 0;
$totcmts = 0;
printf "\n                      Code  Comments\n";
foreach $d (sort (keys %DirCount)) {
    printf "%-20s %6d %6d\n", $d, $DirCount{$d}, $DirComments{$d};
    $tot     += $DirCount{$d};
    $totcmts += $DirComments{$d};
}
printf "\n%-20s %6d %6d\n\n\n", 'TOTAL:', $tot, $totcmts;

$tot = 0;
$totcmts = 0;
printf "\n                      Code  Comments\n";
foreach $m (sort (keys %ModCount)) {
    printf "%-20s %6d %6d\n", $m, $ModCount{$m}, $ModComments{$m};
    $tot += $ModCount{$m};
    $totcmts += $ModComments{$m};
}
printf "\n%-20s %6d %6d\n", 'TOTAL:', $tot, $totcmts;


#!/usr/bin/perl
#
# Licensed to the Apache Software Foundation (ASF) under one
# or more contributor license agreements.  See the NOTICE file
# distributed with this work for additional information
# regarding copyright ownership.  The ASF licenses this file
# to you under the Apache License, Version 2.0 (the
# "License"); you may not use this file except in compliance
# with the License.  You may obtain a copy of the License at
#
#   http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing,
# software distributed under the License is distributed on an
# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
# KIND, either express or implied.  See the License for the
# specific language governing permissions and limitations
# under the License.
#######################################################################
# This script will convert a stack trace with addresses:
#     @           0x5fb015 kudu::master::Master::Init()
#     @           0x5c2d38 kudu::master::MiniMaster::StartOnPorts()
#     @           0x5c31fa kudu::master::MiniMaster::Start()
#     @           0x58270a kudu::MiniCluster::Start()
#     @           0x57dc71 kudu::CreateTableStressTest::SetUp()
# To one with line numbers:
#     @           0x5fb015 kudu::master::Master::Init() at /home/mpercy/src/kudu/src/master/master.cc:54
#     @           0x5c2d38 kudu::master::MiniMaster::StartOnPorts() at /home/mpercy/src/kudu/src/master/mini_master.cc:52
#     @           0x5c31fa kudu::master::MiniMaster::Start() at /home/mpercy/src/kudu/src/master/mini_master.cc:33
#     @           0x58270a kudu::MiniCluster::Start() at /home/mpercy/src/kudu/src/integration-tests/mini_cluster.cc:48
#     @           0x57dc71 kudu::CreateTableStressTest::SetUp() at /home/mpercy/src/kudu/src/integration-tests/create-table-stress-test.cc:61
#
# If the script detects that the output is not symbolized, it will also attempt
# to determine the function names, i.e. it will convert:
#     @           0x5fb015
#     @           0x5c2d38
#     @           0x5c31fa
# To:
#     @           0x5fb015 kudu::master::Master::Init() at /home/mpercy/src/kudu/src/master/master.cc:54
#     @           0x5c2d38 kudu::master::MiniMaster::StartOnPorts() at /home/mpercy/src/kudu/src/master/mini_master.cc:52
#     @           0x5c31fa kudu::master::MiniMaster::Start() at /home/mpercy/src/kudu/src/master/mini_master.cc:33
#######################################################################
use strict;
use warnings;

if (!@ARGV) {
  die <<EOF
Usage: $0 executable [stack-trace-file]

This script will read addresses from a file containing stack traces and
will convert the addresses that conform to the pattern " @ 0x123456" to line
numbers by calling addr2line on the provided executable.
If no stack-trace-file is specified, it will take input from stdin.
EOF
}

# el6 and other older systems don't support the -p flag,
# so we do our own "pretty" parsing.
sub parse_addr2line_output($$) {
  defined(my $output = shift) or die;
  defined(my $lookup_func_name = shift) or die;
  my @lines = grep { $_ ne '' } split("\n", $output);
  my $pretty_str = '';
  if ($lookup_func_name) {
    $pretty_str .= ' ' . $lines[0];
  }
  $pretty_str .= ' at ' . $lines[1];
  return $pretty_str;
}

my $binary = shift @ARGV;
if (! -x $binary || ! -r $binary) {
  die "Error: Cannot access executable ($binary)";
}

# Cache lookups to speed processing of files with repeated trace addresses.
my %addr2line_map = ();

# Disable stdout buffering
$| = 1;

# Reading from <ARGV> is magical in Perl.
while (defined(my $input = <ARGV>)) {
  if ($input =~ /^\s+\@\s+(0x[[:xdigit:]]{6,})(?:\s+(\S+))?/) {
    my $addr = $1;
    my $lookup_func_name = (!defined $2);
    if (!exists($addr2line_map{$addr})) {
      $addr2line_map{$addr} = `addr2line -ifC -e $binary $addr`;
    }
    chomp $input;
    $input .= parse_addr2line_output($addr2line_map{$addr}, $lookup_func_name) . "\n";
  }
  print $input;
}

exit 0;


#!/usr/bin/perl
################################################################################
# Licensed to the Apache Software Foundation (ASF) under one
# or more contributor license agreements.  See the NOTICE file
# distributed with this work for additional information
# regarding copyright ownership.  The ASF licenses this file
# to you under the Apache License, Version 2.0 (the
# "License"); you may not use this file except in compliance
# with the License.  You may obtain a copy of the License at
#
#   http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing,
# software distributed under the License is distributed on an
# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
# KIND, either express or implied.  See the License for the
# specific language governing permissions and limitations
# under the License.
################################################################################
# This script verifies that the dependencies shipped in the Kudu jars do not
# change over time without us noticing.
################################################################################
use strict;
use warnings;

# Prefix for shaded classes.
my $pat_kudu_shaded_prefix = qr{^org/apache/kudu/shaded/};

# Allowed filenames of non-Java files in JARs.
my $pat_allow_non_java =
    qr{(?:\.(?:txt|xml|properties|proto|MF)|
          LICENSE|NOTICE|DEPENDENCIES)$}x;

# Allowed filenames of shaded dependencies in JARs.
my $pat_allow_kudu_shaded =
    qr{^org/apache/kudu/shaded/
        (?:com/google/(?:common|gson|protobuf|thirdparty/publicsuffix)|
           com/sangupta/murmur|
           org/jboss/netty|
           scopt)
      }x;

# Allowed paths of unshaded Kudu dependencies in JARs.
# Currently, there is no restriction imposed for org.apache.kudu classes.
my $pat_allow_kudu_unshaded = qr{^org/apache/kudu/.*};

# Allowed paths of unshaded non-Kudu dependencies in JARs.
my $pat_allow_nonkudu_unshaded = qr{^(?:com/databricks/spark/avro|
                                        com/stumbleupon/async/|
                                        org/apache/parquet/|
                                        org/apache/yetus/)}x;

if (scalar @ARGV != 1) {
  print STDERR "Usage: $0 <dest_dir>\n";
  exit 1;
}

my $dest_dir = $ARGV[0];
chdir($dest_dir) or die "cannot chdir to destination directory $dest_dir: $!";
print "Checking jars in directory: " . `pwd`;

chomp(my @jars = `find . -type f -name \*.jar |
                         grep -v build/jars |
                         grep -v tests\.jar |
                         grep -v tests-shaded\.jar |
                         grep -v original |
                         grep -v sources\.jar |
                         grep -v javadoc\.jar |
                         grep -v unshaded\.jar |
                         grep -v gradle-wrapper.jar`);

my $num_errors = 0;

foreach my $jar (@jars) {
  print "> $jar\n";
  chomp(my @files = `jar tf $jar`);
  foreach my $file (@files) {
    # In each case, ensure the files match the expected patterns.
    if ($file =~ qr{/$}) {
      # A directory. Skip.
    } elsif ($file !~ qr{\.class$}) {
      # Non-Java stuff.
      if ($file !~ $pat_allow_non_java) {
        $num_errors++;
        print "NON_JAVA $file\n";
      }
    } elsif ($file =~ $pat_kudu_shaded_prefix) {
      # Shaded Kudu classes.
      if ($file !~ $pat_allow_kudu_shaded) {
        $num_errors++;
        print "KUDU_SHADED $file\n";
      }
    } elsif ($file =~ qr{^org/apache/kudu}) {
      # Unshaded Kudu classes.
      if ($file !~ $pat_allow_kudu_unshaded) {
        $num_errors++;
        print "KUDU_UNSHADED $file\n";
      }
    } else {
      # Non-Kudu classes.
      if ($file !~ $pat_allow_nonkudu_unshaded) {
        $num_errors++;
        print "NON_KUDU $file\n";
      }
    }
  }
}

if ($num_errors != 0) {
  print "Found $num_errors errors.\n";
  exit 1;
}
print "OK.\n";
exit 0;


#!/usr/bin/env perl
#
# Licensed to the Apache Software Foundation (ASF) under one
# or more contributor license agreements.  See the NOTICE file
# distributed with this work for additional information
# regarding copyright ownership.  The ASF licenses this file
# to you under the Apache License, Version 2.0 (the
# "License"); you may not use this file except in compliance
# with the License.  You may obtain a copy of the License at
#
#   http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing,
# software distributed under the License is distributed on an
# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
# KIND, either express or implied.  See the License for the
# specific language governing permissions and limitations
# under the License.

print "time\ttput\n";
while (<>) {
  next unless /sec;/;
  next if /CLEANUP/;
  if (/(\d+) sec.*?([\d.]+) current ops./) {
    print "$1\t$2\n";
  }
}


#!/usr/bin/perl
################################################################################
#
# Licensed to the Apache Software Foundation (ASF) under one
# or more contributor license agreements.  See the NOTICE file
# distributed with this work for additional information
# regarding copyright ownership.  The ASF licenses this file
# to you under the Apache License, Version 2.0 (the
# "License"); you may not use this file except in compliance
# with the License.  You may obtain a copy of the License at
#
#   http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing,
# software distributed under the License is distributed on an
# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
# KIND, either express or implied.  See the License for the
# specific language governing permissions and limitations
# under the License.
#
# Kudu log parser. Summarize delays potentially related to RaftConsensus
# activity across a cluster.
# Pass it a list of logs from a whole cluster.
# The logs are allowed to be gzipped.
################################################################################
use strict;
use warnings;

use Getopt::Long qw(GetOptions);
use Data::Dumper qw(Dumper);
use DateTime;
use DateTime::Format::Strptime;
use Date::Parse qw(str2time);

sub main();
sub process_file($$$);
sub print_history(@);
sub print_record($$);
sub duration_to_nanos($);
sub glog_timestamp_to_micros($$);
sub timestamp_string_to_micros($);
sub format_ts($);
sub format_duration_micros($);

# Extension of gzip files.
my $pat_gzip_ext = qr/\.gz$/;

# Log line patterns
# -----------------
my $pat_glog_prefix = qr{^[A-Z](\d{4}) (\d{2}:\d{2}:\d{2}\.\d{6})\s+\d+ \S+\]};
my $pat_tablet_prefix = qr{$pat_glog_prefix T (\S+) P (\S+)};
my $pat_raft_prefix = qr{$pat_tablet_prefix \[term (\d+) (\w+)\]:};
my $pat_raft_election_prefix = qr{$pat_tablet_prefix \[CANDIDATE\]: Term (\d+) ((?:pre-)?election):};

# W0912 11:19:51.896980 30674 consensus_peers.cc:365] T 45765f7e72ae4923aa5ba2a7df69fabf P b80b06235d304dad93ada855a442e051 -> Peer 5b25d072a0864275806370a4834f1dad (foo.example.com:7050): Couldn't send request to peer 5b25d072a0864275806370a4834f1dad for tablet 45765f7e72ae4923aa5ba2a7df69fabf. Status: Timed out: UpdateConsensus RPC to 10.0.0.7:7050 timed out after 1.000s (SENT). Retrying in the next heartbeat period. Already tried 4 times.
my $pat_raft_hb_timeout = qr{$pat_tablet_prefix -> Peer (\S+) (\(\S+\)): .* Timed out: UpdateConsensus RPC .* timed out after ([\d.]+)s};

# I0926 11:16:07.158995  3293 raft_consensus.cc:436] T 3480ca98bb444244b73fe9ee082d1449 P b80b06235d304dad93ada855a442e051 [term 42155 FOLLOWER]: Starting leader election with config: opid_index: 31577 OBSOLETE_local: false peers { permanent_uuid: "a283d70a0bfb4ef8a324e4f0893bfa2d" member_type: VOTER last_known_addr { host: "host1.example.com" port: 7050 } } peers { permanent_uuid: "5b25d072a0864275806370a4834f1dad" member_type: VOTER last_known_addr { host: "host2.example.com" port: 7050 } } peers { permanent_uuid: "b80b06235d304dad93ada855a442e051" member_type: VOTER last_known_addr { host: "host3.example.com" port: 7050 } }
my $pat_raft_start_election = qr{$pat_raft_prefix Starting (?:(?:forced )?leader )?((?:pre-)?election) \(([^)]+)\)$};

# I0926 11:17:05.697587 15122 leader_election.cc:243] T 45765f7e72ae4923aa5ba2a7df69fabf P 5b25d072a0864275806370a4834f1dad [CANDIDATE]: Term 37134 pre-election: Election decided. Result: candidate won.
# I0926 11:17:05.697796 15121 leader_election.cc:243] T efc242c62e0746e9b6514fc67d90daac P 5b25d072a0864275806370a4834f1dad [CANDIDATE]: Term 29786 pre-election: Election decided. Result: candidate lost.
# I0118 19:08:21.448396 26370 leader_election.cc:258] T 961748f097f64ff09b3e803a1fdff15e P 23d473f441674d43807fd9e631862bfd [CANDIDATE]: Term 2010 election: Election decided. Result: candidate won.
my $pat_raft_election_result = qr{$pat_raft_election_prefix Election decided\. Result: candidate (\w+)\.};

# W0926 11:17:05.697788 15121 leader_election.cc:272] T efc242c62e0746e9b6514fc67d90daac P 5b25d072a0864275806370a4834f1dad [CANDIDATE]: Term 29786 pre-election: RPC error from VoteRequest() call to peer a283d70a0bfb4ef8a324e4f0893bfa2d: Timed out: RequestConsensusVote RPC to 10.0.0.50:7050 timed out after 1.512s (SENT)
my $pat_raft_election_timeout = qr{$pat_raft_election_prefix RPC error from VoteRequest\(\) call to peer (\w+): (.*)$};

# I0926 11:18:08.630019 10465 raft_consensus.cc:519] T 6082f57e00094402a7ff15ae4795dac5 P b80b06235d304dad93ada855a442e051 [term 41550 LEADER]: Becoming Leader. State: Replica: b80b06235d304dad93ada855a442e051, State: 1, Role: LEADER
my $pat_raft_becoming_leader = qr{$pat_raft_prefix Becoming Leader\.};

# I0912 11:19:51.976449 30979 raft_consensus.cc:1861] T fa265673c946476592e781921b90e8c3 P b80b06235d304dad93ada855a442e051 [term 21610 LEADER]: Leader pre-election vote request: Denying vote to candidate 5b25d072a0864275806370a4834f1dad for term 21611 because replica is either leader or believes a valid leader to be alive.
my $pat_raft_deny_vote = qr{$pat_raft_prefix Leader (\S+) vote request: Denying vote to candidate (\S+) for term (\d+) because (.*?)[.]?$};

# I0926 11:16:11.727576 15199 raft_consensus.cc:1900] T 40e5b8a7ba8d4770a8eadcdae0c210c8 P 5b25d072a0864275806370a4834f1dad [term 18965 FOLLOWER]: Leader pre-election vote request: Granting yes vote for candidate a283d70a0bfb4ef8a324e4f0893bfa2d in term 18965.
my $pat_raft_grant_vote = qr{$pat_raft_prefix Leader (\S+) vote request: Granting yes vote for candidate (\S+) in term (\d+)\.$};

# W0926 11:18:56.379592 26278 outbound_call.cc:232] RPC callback for RPC call kudu.consensus.ConsensusService.UpdateConsensus -> {remote=10.0.0.50:7050, user_credentials={real_user=kudu}} blocked reactor thread for 50364.1us
my $pat_blocked_reactor = qr{$pat_glog_prefix RPC callback for RPC call (\S+) -> \{remote=(\S+), user_credentials=\{real_user=kudu\}\} blocked reactor thread for (\S+)$};

# W0926 11:17:05.677790 15105 kernel_stack_watchdog.cc:146] Thread 15122 stuck at /home/mpercy/src/kudu/src/kudu/rpc/outbound_call.cc:218 for 166ms:
my $pat_kernel_stack_watchdog = qr{$pat_glog_prefix Thread (\d+) stuck at .*/([^/]+\.\w+):(\d+) for (\S+):$};

# W0926 11:19:01.339553 27231 net_util.cc:129] Time spent resolving address for foo1.example.com: real 0.202s    user 0.000s     sys 0.000s
my $pat_slow_execution = qr{$pat_glog_prefix .*(Time spent .*): real (\S+)};

# Global datetime formatter object.
my $g_dt_formatter = DateTime::Format::Strptime->new(pattern => "%m/%d %H:%M:%S.%6N");

use constant RAW_LOG_LINE      => '';
use constant RAFT_UPDT_TIMEOUT => 'RAFT_UPDT_TIMEOUT';
use constant BECOMING_LEADER   => 'BECOMING_LEADER  ';
use constant ELECTION_STARTING => 'ELECTION_START   ';
use constant VOTE              => 'VOTE             ';
use constant BLOCKED_REACTOR   => 'BLOCKED_REACTOR  ';
use constant KERNEL_DELAY      => 'KERNEL_DELAY     ';
use constant SLOW_EXECUTION    => 'SLOW_EXECUTION   ';
use constant ELECTION_RESULT   => 'ELECTION_RESULT  ';
use constant VOTE_REQ_TIMEOUT  => 'VOTE_REQ_TIMEOUT ';

########################################################################

my $rc = main();
exit $rc;

########################################################################

sub main() {
  if (!@ARGV) {
    print STDERR "Usage: $0 [options] <glog1> [<glog2> ...]\n";
    print STDERR "Where the following options are available:\n";
    print STDERR "  --tablet <tablet-id>      Filter by tablet id\n";
    print STDERR "  --nosummary               Print raw log lines\n";
    print STDERR "  --before <ts>             Only include lines with timestamp earlier than or equal to <ts>\n";
    print STDERR "  --after <ts>              Only include lines with timestamp later than or equal to <ts>\n";
    print STDERR "Note that many formats are supported for <ts>. See 'perldoc Date::Parse' for details.\n";
    return 1;
  }

  my %opts;
  GetOptions(\%opts,
             "tablet=s",
             "nosummary",
             "before=s",
             "after=s") or die "Error in command-line arguments: $!";

  my $tot_lines = 0;
  my @records = ();
  foreach my $file (@ARGV) {
    $tot_lines += process_file($file, \%opts, \@records);
  }
  #print STDERR "Number of lines: $tot_lines\n";
  #print STDERR "Number of records: " . scalar @records . "\n";
  print_history(@records);

  return 0;
}

sub process_file($$$) {
  defined(my $file = shift) or die;
  defined(my $opts = shift) or die;
  defined(my $records = shift) or die;

  # Support gzipped files.
  if ($file =~ $pat_gzip_ext) {
    open(IN, "gunzip -c $file |") or die "can't open gunzip pipe to $file: $!";
  } else {
    open(IN, "< $file") or die "can't open $file: $!";
  }

  print STDERR "processing file $file...\n";

  my $min_ts_micros = 0;
  my $max_ts_micros = 2**64 - 1;

  if (exists $opts->{before}) {
    $max_ts_micros = timestamp_string_to_micros($opts->{before});
  }
  if (exists $opts->{after}) {
    $min_ts_micros = timestamp_string_to_micros($opts->{after});
  }

  my $line_count = 0;
  while (defined(my $line = <IN>)) {
    $line_count++;
    # Skip non-glog lines.
    next unless $line =~ $pat_glog_prefix;
    my ($date, $ts) = ($1, $2);
    my $ts_micros = glog_timestamp_to_micros($date, $ts);
    next unless $ts_micros >= $min_ts_micros;
    next unless $ts_micros <= $max_ts_micros;

    chomp $line;

    if (exists $opts->{nosummary}) {
      if (exists $opts->{tablet}) {
        next unless (my @m = $line =~ $pat_tablet_prefix);
        my ($date, $ts, $tablet_id, $local_peer_uuid) = @m;
        next unless $tablet_id eq $opts->{tablet};
      }
      push @$records, {ts => $ts_micros, type => RAW_LOG_LINE(),
                       data => {line => $line}};
      next;
    }

    if (my @m = $line =~ $pat_raft_hb_timeout) {
      my ($date, $ts, $tablet_id, $local_peer_uuid, $remote_peer_uuid, $remote_peer_host, $timeout_sec) = @m;
      next if exists $opts->{tablet} && $tablet_id ne $opts->{tablet};
      push @$records, {ts => $ts_micros, type => RAFT_UPDT_TIMEOUT(),
                       data => {tablet_id => $tablet_id, local_peer_uuid => $local_peer_uuid,
                               remote_peer_uuid => $remote_peer_uuid}};
      next;
    }

    if (my @m = $line =~ $pat_raft_start_election) {
      my ($date, $ts, $tablet_id, $local_peer_uuid, $local_peer_term, $local_peer_role, $election_type, $reason) = @m;
      next if exists $opts->{tablet} && $tablet_id ne $opts->{tablet};
      push @$records, {ts => $ts_micros, type => ELECTION_STARTING(),
                       data => {tablet_id => $tablet_id, local_peer_uuid => $local_peer_uuid,
                               local_peer_term => $local_peer_term, local_peer_role => $local_peer_role,
                               election_type => $election_type, reason => $reason}};
      next;
    }

    if (my @m = $line =~ $pat_raft_election_result) {
      my ($date, $ts, $tablet_id, $local_peer_uuid, $local_peer_term, $election_type, $result) = @m;
      next if exists $opts->{tablet} && $tablet_id ne $opts->{tablet};
      push @$records, {ts => $ts_micros, type => ELECTION_RESULT(),
                       data => {tablet_id => $tablet_id, local_peer_uuid => $local_peer_uuid,
                               local_peer_term => $local_peer_term, election_type => $election_type,
                               result => $result}};
      next;
    }

    if (my @m = $line =~ $pat_raft_election_timeout) {
      my ($date, $ts, $tablet_id, $local_peer_uuid, $local_peer_term, $election_type, $remote_peer_uuid, $error) = @m;
      next if exists $opts->{tablet} && $tablet_id ne $opts->{tablet};
      push @$records, {ts => $ts_micros, type => VOTE_REQ_TIMEOUT(),
                       data => {tablet_id => $tablet_id, local_peer_uuid => $local_peer_uuid,
                               local_peer_term => $local_peer_term,  election_type => $election_type,
                               remote_peer_uuid => $remote_peer_uuid,
                               error => $error}};
      next;
    }

    if (my @m = $line =~ $pat_raft_becoming_leader) {
      my ($date, $ts, $tablet_id, $local_peer_uuid, $local_peer_term, $local_peer_role) = @m;
      next if exists $opts->{tablet} && $tablet_id ne $opts->{tablet};
      push @$records, {ts => $ts_micros, type => BECOMING_LEADER(),
                       data => {tablet_id => $tablet_id, local_peer_uuid => $local_peer_uuid,
                               local_peer_term => $local_peer_term, local_peer_role => $local_peer_role}};
      next;
    }

    if (my @m = $line =~ $pat_raft_deny_vote) {
      next; # We don't really care about denied votes since they are not very expensive
      my ($date, $ts, $tablet_id, $local_peer_uuid, $local_peer_term, $local_peer_role,
          $election_type, $remote_peer_uuid, $remote_peer_term, $reason) = @m;
      next if exists $opts->{tablet} && $tablet_id ne $opts->{tablet};
      push @$records, {ts => $ts_micros, type => VOTE(),
                       data => {tablet_id => $tablet_id, local_peer_uuid => $local_peer_uuid,
                               local_peer_term => $local_peer_term, local_role => $local_peer_role,
                               election_type => $election_type, remote_peer_uuid => $remote_peer_uuid,
                               remote_peer_term => $remote_peer_term, reason => $reason, result => "DENIED"}};
      next;
    }

    if (my @m = $line =~ $pat_raft_grant_vote) {
      my ($date, $ts, $tablet_id, $local_peer_uuid, $local_peer_term, $local_peer_role, $election_type,
          $remote_peer_uuid, $remote_peer_term) = @m;
      next if exists $opts->{tablet} && $tablet_id ne $opts->{tablet};
      push @$records, {ts => $ts_micros, type => VOTE(),
                       data => {tablet_id => $tablet_id, local_peer_uuid => $local_peer_uuid,
                               local_peer_term => $local_peer_term, local_role => $local_peer_role,
                               election_type => $election_type, remote_peer_uuid => $remote_peer_uuid,
                               remote_peer_term => $remote_peer_term, reason => "", result => "GRANTED"}};
      next;

    }

    if (my @m = $line =~ $pat_blocked_reactor) {
      my ($date, $ts, $rpc, $remote_addr, $duration_str) = @m;
      my $duration_micros = duration_to_micros($duration_str);
      push @$records, {ts => $ts_micros, type => BLOCKED_REACTOR(),
                       data => {rpc => $rpc, remote_addr => $remote_addr, duration_micros => $duration_micros}};
      next;
    }

    if (my @m = $line =~ $pat_kernel_stack_watchdog) {
      my ($date, $ts, $thread, $file, $line, $duration_str) = @m;
      my $duration_micros = duration_to_micros($duration_str);
      push @$records, {ts => $ts_micros, type => KERNEL_DELAY(),
                       data => {thread => $thread, file => $file, line => $line, duration_micros => $duration_micros}};
      next;
    }

    if (my @m = $line =~ $pat_slow_execution) {
      my ($date, $ts, $task, $duration_str) = @m;
      my $duration_micros = duration_to_micros($duration_str);
      push @$records, {ts => $ts_micros, type => SLOW_EXECUTION(),
                       data => {task => $task, duration_micros => $duration_micros}};
      next;
    }
  }

  return $line_count;
}

sub print_history(@) {
  # TODO(mpercy): sort individual files and merge them at the end.
  @_ = sort { $a->{ts} <=> $b->{ts} } @_;
  my $first_dup_record = undef;
  my $dup_rec_count = undef;
  foreach my $record (@_) {
    # Accumulate consecutive duplicates.
    if (defined $first_dup_record &&
        ($record->{type} eq RAFT_UPDT_TIMEOUT || $record->{type} eq VOTE || $record->{type} eq ELECTION_STARTING) &&
         $record->{type} eq $first_dup_record->{type} &&
         $record->{data}{tablet_id} eq $first_dup_record->{data}{tablet_id}) {
      # It's a dup.
      ++$dup_rec_count;
      next;
    }
    # Print previous record, if it's there.
    if (defined $first_dup_record) {
      print_record($first_dup_record, $dup_rec_count);
    }
    # Reset the dup count.
    $first_dup_record = $record;
    $dup_rec_count = 1;
  }

  if (defined $first_dup_record) {
    print_record($first_dup_record, $dup_rec_count);
  }
}

sub print_record($$) {
  defined(my $record = shift) or die "Undefined record";
  defined(my $count = shift) or die "Undefined count";
  my $date_str = format_ts($record->{ts});
  my $data = $record->{data};
  if ($record->{type} eq RAW_LOG_LINE) {
    print $data->{line};
  } elsif ($record->{type} eq ELECTION_STARTING) {
    print join("\t", $date_str, $record->{type}, $data->{election_type}, $data->{tablet_id}, $data->{local_peer_uuid},
                     $data->{local_peer_term}, $data->{reason});
  } elsif ($record->{type} eq ELECTION_RESULT) {
    print join("\t", $date_str, $record->{type}, $data->{election_type}, $data->{tablet_id}, $data->{local_peer_uuid},
                     $data->{local_peer_term}, uc($data->{result}));
  } elsif ($record->{type} eq VOTE_REQ_TIMEOUT) {
    print join("\t", $date_str, $record->{type}, $data->{election_type}, $data->{tablet_id}, $data->{local_peer_uuid},
                     $data->{remote_peer_uuid}, $data->{local_peer_term}, $data->{error});
  } elsif ($record->{type} eq BECOMING_LEADER) {
    print join("\t", $date_str, $record->{type}, $data->{tablet_id}, $data->{local_peer_uuid}, $data->{local_peer_term});
  } elsif ($record->{type} eq VOTE) {
    print join("\t", $date_str, $record->{type}, $data->{election_type}, $data->{tablet_id}, $data->{local_peer_uuid},
                     $data->{remote_peer_uuid}, $data->{election_type}, $data->{result}, $data->{reason});
  } elsif ($record->{type} eq RAFT_UPDT_TIMEOUT) {
    print join("\t", $date_str, $record->{type}, $data->{tablet_id}, $data->{local_peer_uuid}, $data->{remote_peer_uuid});
  } elsif ($record->{type} eq BLOCKED_REACTOR) {
    my $duration_str = format_duration_micros($data->{duration_micros});
    print join("\t", $date_str, $record->{type}, $data->{rpc}, $data->{remote_addr}, $duration_str);
  } elsif ($record->{type} eq KERNEL_DELAY) {
    my $duration_str = format_duration_micros($data->{duration_micros});
    print join("\t", $date_str, $record->{type}, $data->{thread}, $data->{file} . ':' . $data->{line}, $duration_str);
  } elsif ($record->{type} eq SLOW_EXECUTION) {
    my $duration_str = format_duration_micros($data->{duration_micros});
    print join("\t", $date_str, $record->{type}, $data->{task}, $duration_str);
  } else {
    die "Unsupported record type: " . $record->{type};
  }
  print " (repeated $count times)" if $count > 1;
  print "\n";
}

# Parse a duration string like "41.2ms" and convert it to microseconds.
sub duration_to_micros($) {
  defined(my $str = shift) or die "Undefined duration";
  if ($str !~ /^([\d.e+-]+)([A-Za-z]+)$/) {
    die "Unsupported duration format: $str";
  }
  my $num = $1 + 0.0;
  my $units = $2;
  if ($units eq 'ns') { return $num / 1000; }
  if ($units eq 'us') { return $num; }
  if ($units eq 'ms') { return $num * 1000; }
  if ($units eq 's' || $units eq 'sec') { return $num * 1000 * 1000; }
  if ($units eq 'm' || $units eq 'min') { return $num * 1000 * 1000 * 60; }
  die "Unsupported units ($units): $str";
}

# Convert the date and timestamp parsed from a glog log prefix (see regular
# expression at the top of this file) to UNIX time in microseconds.
sub glog_timestamp_to_micros($$) {
  defined(my $date = shift) or die;
  defined(my $ts = shift) or die;
  if ($date !~ /^(\d\d)(\d\d)$/) {
    die "Bad date format: $date";
  }
  my ($month, $day) = ($1, $2);
  my $strp = new DateTime::Format::Strptime(
      pattern => '%Y/%m/%d %H:%M:%S.%6N',
      time_zone   => 'UTC', # Arbitrary TZ.
      on_error => 'croak',
  );
  my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime();
  $year += 1900;
  my $dt  = $strp->parse_datetime("$year/$month/$day $ts");
  if (!$dt) {
    print STDERR "Warning: Unable to parse date: $date $ts ($month/$day $ts)\n";
    return 0;
  }
  return $dt->epoch() * 1000_000 + $dt->microsecond();
}

# Convert a user-specified timestamp to UNIX time in microseconds.
# For supported date and time formats, see `perldoc Date::Parse`.
sub timestamp_string_to_micros($) {
  defined(my $date = shift) or die;
  my $unixtime = str2time($date);
  return $unixtime * 1000_000; # Return UNIX timestamp in microseconds.
}

sub format_ts($) {
  defined(my $epoch_micros = shift) or die;
  my $dt = DateTime->from_epoch(epoch => $epoch_micros / 1000_000);
  $dt->set_nanosecond($epoch_micros % 1000_000 * 1000);
  return $g_dt_formatter->format_datetime($dt);
}

sub format_duration_micros($) {
  defined(my $duration = shift) or die;
  my $duration_sec = int($duration / 1000_000);
  my $duration_micros = $duration % 1000_000;
  return sprintf("%0d.%06ds", $duration_sec, $duration_micros);
}


#!/usr/bin/perl
######################################################################
#
# Licensed to the Apache Software Foundation (ASF) under one
# or more contributor license agreements.  See the NOTICE file
# distributed with this work for additional information
# regarding copyright ownership.  The ASF licenses this file
# to you under the Apache License, Version 2.0 (the
# "License"); you may not use this file except in compliance
# with the License.  You may obtain a copy of the License at
#
#   http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing,
# software distributed under the License is distributed on an
# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
# KIND, either express or implied.  See the License for the
# specific language governing permissions and limitations
# under the License.
######################################################################
# Tool to parse the output of "debug" refcounted objects.
# This is helpful for tracking down ref-counting leaks.
# Generate compatible logs by making your refcounted object inherit
# from kudu::DebugRefCountedThreadSafe<T>.
######################################################################
use strict;
use warnings;

my $verbose = 0;
while ($ARGV[0] =~ /^-v/) {
  shift;
  $verbose++;
}
my $infile = shift;

if (!defined $infile || $infile eq '-h' || $infile eq '-help' || $infile eq '--help') {
  die "Usage: $0 [-v] input.log\n";
}

open(FILE, "< $infile") or die "Error: unable to open input file ($infile) for read: $!";
my $content = '';
read(FILE, $content, -s FILE) or die "Error: unable to read input file ($infile): $!";
close FILE;

my @lines = split /\n/, $content;
chomp @lines;

# First, find all the objects we are interested in.
# The really interesting ones have a mismatch in their Inc/Dec counts.

my @incdec = grep { /Incremented ref|Decrementing ref/ } @lines;
my %counts = (); # map of address -> final ref count
foreach my $line (@incdec) {
  if ($line =~ /(Incremented|Decrementing) ref on (0x[a-z0-9]+):/) {
    my $op = $1;
    my $addr = $2;
    if ($op eq 'Incremented') {
      $counts{$addr}++;
    } else {
      $counts{$addr}--;
    }
  }
}

my @bad_addrs = ();
foreach my $addr (sort keys %counts) {
  if ($counts{$addr} != 0) {
    push @bad_addrs, $addr;
  }
}

# Print all the interesting stack traces of the relevant addresses.
foreach my $addr (@bad_addrs) {
  print "Address $addr has bad ref count: " . ($counts{$addr}) . "\n";
  # Parse the stack traces:
  # Find a debug line and grab thru the next two lines that contain "kudu",
  # which should be kudu::DebugRefCountedThreadSafe frame through the likely
  # "interesting" frame where the scoped_refptr was instantiated or destroyed.
  my @matches = $content =~ /([^\n]*(?:Incremented|Decrementing) ref on $addr:\n.*?[^\n]+kudu[^\n]+\n.*?[^\n]+kudu[^\n]+\n)/smg;
  foreach (@matches) {
    if ($verbose) {
      # In "verbose" mode, print a slightly larger trace.
      print;
    } else {
      # Regular mode... we just try to get the frame that caused the ref change.
      chomp;
      s/\n.*\n//sm;   # Only keep the first and last lines.
      s/\s+\@\s+/ /;  # Make it look a little nicer.
      print "$_\n";
    }
  }
}


#!/usr/bin/perl

# Copyright (c) 2009, 2012, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA

use strict;
use Cwd 'abs_path';
use File::Basename;

my $cmakeargs = "";

# Find source root directory
# Assume this script is in <srcroot>/cmake
my $srcdir = dirname(dirname(abs_path($0)));
my $cmake_install_prefix="";

# Sets installation directory,  bindir, libdir, libexecdir etc
# the equivalent CMake variables are given without prefix
# e.g if --prefix is /usr and --bindir is /usr/bin
# then cmake variable (INSTALL_BINDIR) must be just "bin"

sub set_installdir
{
   my($path, $varname) = @_;
   my $prefix_length = length($cmake_install_prefix);
   if (($prefix_length > 0) && (index($path,$cmake_install_prefix) == 0))
   {
      # path is under the prefix, so remove the prefix and maybe following "/"
      $path = substr($path, $prefix_length);
      if(length($path) > 0)
      {
        my $char = substr($path, 0, 1);
        if($char eq "/")
        {
          $path= substr($path, 1);
        }
      }
      if(length($path) > 0)
      {
        $cmakeargs = $cmakeargs." -D".$varname."=".$path;
      }
   }
}

# CMake understands CC and CXX env.variables correctly, if they  contain 1 or 2 tokens
# e.g CXX=g++ and CXX="ccache g++" are ok. However it could have a problem if there
# (recognizing g++) with more tokens ,e.g CXX="ccache g++ --pipe".
# The problem is simply fixed by splitting compiler and flags, e.g
# CXX="ccache g++ --pipe" => CXX=ccache g++ CXXFLAGS=--pipe

sub check_compiler
{
  my ($varname, $flagsvarname) = @_;
  my @tokens = split(/ /,$ENV{$varname});
  if($#tokens >= 2)
  {
    $ENV{$varname} = $tokens[0]." ".$tokens[1];
    my $flags;

    for(my $i=2; $i<=$#tokens; $i++)
    {
      $flags= $flags." ".$tokens[$i];
    }
    if(defined $ENV{$flagsvarname})
    {
      $flags = $flags." ".$ENV{$flagsvarname};
    }
    $ENV{$flagsvarname}=$flags;
    print("$varname=$ENV{$varname}\n");
    print("$flagsvarname=$ENV{$flagsvarname}\n");
  }
}

check_compiler("CC", "CFLAGS");
check_compiler("CXX", "CXXFLAGS");

if(defined $ENV{"CXX"} and $ENV{"CXX"} =~ m/gcc/)
{
  my $old_cxx= $ENV{"CXX"};
  $ENV{"CXX"} =~ s/gcc/g++/;
  print("configure.pl : switching CXX compiler from $old_cxx to $ENV{CXX}\n");
}

if(defined $ENV{"CXXFLAGS"} and $ENV{"CXXFLAGS"} =~ "-fno-exceptions")
{
  $ENV{"CXXFLAGS"} =~ s/-fno-exceptions//;
  print("configure.pl : stripping off -fno-exceptions CXXFLAGS=$ENV{CXXFLAGS}\n");
}

foreach my $option (@ARGV)
{
  if (substr ($option, 0, 2) eq "--")
  {
    $option = substr($option, 2);
  }
  else
  {
    # This must be environment variable
    my @v  = split('=', $option);
    my $name = shift(@v);
    if(@v)
    {
      $ENV{$name} = join('=', @v);
    }
    next;
  }
  if($option =~ /srcdir/)
  {
    $srcdir = substr($option,7);
    next;
  }
  if($option =~ /help/)
  {
    system("cmake ${srcdir} -LH");
    exit(0);
  }
  if($option =~ /with-plugins=/)
  {
    my @plugins= split(/,/, substr($option,13));
    foreach my $p (@plugins)
    {
      $p =~ s/-/_/g;
      $cmakeargs = $cmakeargs." -DWITH_".uc($p)."=1";
    }
    next;
  }
  if($option =~ /with-extra-charsets=/)
  {
    my $charsets= substr($option,20);
    $cmakeargs = $cmakeargs." -DWITH_EXTRA_CHARSETS=".$charsets;
    next;
  }
  if($option =~ /without-plugin=/)
  {
    $cmakeargs = $cmakeargs." -DWITHOUT_".uc(substr($option,15))."=1";
    next;
  }
  if($option =~ /with-zlib-dir=bundled/)
  {
    $cmakeargs = $cmakeargs." -DWITH_ZLIB=bundled";
    next;
  }
  if($option =~ /with-zlib-dir=/)
  {
    $cmakeargs = $cmakeargs." -DWITH_ZLIB=system";
    next;
  }
  if($option =~ /with-libevent=/)
  {
    $cmakeargs = $cmakeargs." -DWITH_LIBEVENT=system";
    next;
  }
  if($option =~ /with-libevent/)
  {
    $cmakeargs = $cmakeargs." -DWITH_LIBEVENT=bundled";
    next;
  }
  if($option =~ /with-ssl=/)
  {
    $cmakeargs = $cmakeargs." -DWITH_SSL=yes";
    next;
  }
  if($option =~ /with-ssl/)
  {
    $cmakeargs = $cmakeargs." -DWITH_SSL=bundled";
    next;
  }
  if($option =~ /prefix=/)
  {
    $cmake_install_prefix= substr($option, 7);
    $cmakeargs = $cmakeargs." -DCMAKE_INSTALL_PREFIX=".$cmake_install_prefix;
    next;
  }
  if($option =~/bindir=/)
  {
    set_installdir(substr($option,7), "INSTALL_BINDIR");
    next;
  }
  if($option =~/libdir=/)
  {
    set_installdir(substr($option,7), "INSTALL_LIBDIR");
    next;
  }
  if($option =~/libexecdir=/)
  {
    set_installdir(substr($option,11), "INSTALL_SBINDIR");
    next;
  }
  if($option =~/includedir=/)
  {
    set_installdir(substr($option,11), "INSTALL_INCLUDEDIR");
    next;
  }
  if ($option =~ /extra-charsets=all/)
  {
    $cmakeargs = $cmakeargs." -DWITH_CHARSETS=all";
    next;
  }
  if ($option =~ /extra-charsets=complex/)
  {
    $cmakeargs = $cmakeargs." -DWITH_CHARSETS=complex";
    next;
  }
  if ($option =~ /localstatedir=/)
  {
    $cmakeargs = $cmakeargs." -DMYSQL_DATADIR=".substr($option,14);
    next;
  }
  if ($option =~ /with-comment=/)
  {
    $cmakeargs = $cmakeargs." \"-DWITH_COMMENT=".substr($option,13)."\"";
    next;
  }
  if ($option =~ /mysql-maintainer-mode/)
  {
    $cmakeargs = $cmakeargs." -DMYSQL_MAINTAINER_MODE=" .
                 ($option =~ /enable/ ? "1" : "0");
    next;
  }
  if ($option =~ /with-comment=/)
  {
    $cmakeargs = $cmakeargs." \"-DWITH_COMMENT=".substr($option,13)."\"";
    next;
  }
  if ($option =~ /with-gcov/)
  {
      $cmakeargs = $cmakeargs." -DENABLE_GCOV=ON";
      next;
  }
  if ($option =~ /with-client-ldflags/)
  {
      print("configure.pl : ignoring $option\n");
      next;
  }
  if ($option =~ /with-mysqld-ldflags=/)
  {
      print("configure.pl : ignoring $option\n");
      next;
  }

  $option = uc($option);
  $option =~ s/-/_/g;
  $cmakeargs = $cmakeargs." -D".$option."=1";
}

print("configure.pl : calling cmake $srcdir $cmakeargs\n");
unlink("CMakeCache.txt");
my $rc = system("cmake $srcdir $cmakeargs");
exit($rc);


#!/usr/bin/perl -w

#
# Copyright (c) 2016 Facebook, Inc.
# All rights reserved
#

#
# Git hash/date header file generator
#

use strict;

use Cwd;
use File::Copy qw(copy);
use Getopt::Long qw(GetOptions);
use Pod::Usage qw(pod2usage);

sub check_all_or_none {
  my $bitmask = 0;

  $bitmask = $bitmask | 1 if shift ne "";
  $bitmask = $bitmask | 2 if shift ne "";
  $bitmask = $bitmask | 4 if shift ne "";
  $bitmask = $bitmask | 8 if shift ne "";

  pod2usage("You must specify none or all of the git hashes and dates")
      unless ($bitmask == 0 || $bitmask == 15);
}

# Function to retrieve the git hash and date from a repository
sub git_hash_and_date {
  my $subdir = shift;
  my $orgdir = Cwd::getcwd;

  # Switch directories to the specified one
  chdir($subdir) or die "Can't change directory to '$subdir'";

  # Get the hash and date from the most recent revision in the repository
  my $git_cmd = "git log -1 --format=\"%H;%cI\"";
  open (my $log, "$git_cmd |") or die "Can't run $git_cmd";

  my $githash = "";
  my $gitdate = "";

  # Loop through all the lines - we should only have one line
  while (<$log>) {
    # Search for a line that has a hash, a semicolon and the date
    if (/^([0-9a-f]{7,40});(.*)\n/) {
      die "Unexpected multiple matching log lines" unless !length($githash);
      $githash = $1;
      $gitdate = $2;
    }
  }

  # Make sure we got something
  die "No matching log lines" unless length($githash);

  # Close the input and switch back to the original subdirectory
  close($log);
  chdir($orgdir);

  # Return the found hash and date
  return ($githash, $gitdate);
}

# main function
sub main {
  my $root = "";
  my $infile = "";
  my $mysql_git_hash = "";
  my $mysql_git_date = "";
  my $rocksdb_git_hash = "";
  my $rocksdb_git_date = "";
  my $help = 0;

  # Get the parameters
  GetOptions(
    'help|?' => \$help,
    'git_root=s' => \$root,
    'file=s' => \$infile,
    'mysql_githash=s' => \$mysql_git_hash,
    'mysql_gitdate=s' => \$mysql_git_date,
    'rocksdb_githash=s' => \$rocksdb_git_hash,
    'rocksdb_gitdate=s' => \$rocksdb_git_date
  ) or pod2usage();

  # Validate the parameters
  pod2usage(-verbose => 1) if $help;
  pod2usage("missing required parameter --git_root") if $root eq "";
  pos2usage("missing required parameter --file") if $infile eq "";
  check_all_or_none($mysql_git_hash, $mysql_git_date,
                    $rocksdb_git_hash, $rocksdb_git_date);

  my $rocksdb = "$root/rocksdb";
  my $outfile = "$infile.tmp";

  if ($mysql_git_hash eq "") {
    # retrieve the git hash and date for the main repository
    ($mysql_git_hash, $mysql_git_date) = git_hash_and_date $root;
    # retrieve the git hash and date for the rocksdb submodule
    ($rocksdb_git_hash, $rocksdb_git_date) = git_hash_and_date $rocksdb;
  }

  # Open the user's file for reading and a temporary file for writing
  open(my $in, "<", $infile) or die "Could not open '$infile'";
  open(my $out, ">", $outfile) or die "Could not create '$outfile'";

  # For each line, see if we can replace anything
  while (<$in>) {
    s/\@MYSQL_GIT_HASH\@/$mysql_git_hash/g;
    s/\@MYSQL_GIT_DATE\@/$mysql_git_date/g;
    s/\@ROCKSDB_GIT_HASH\@/$rocksdb_git_hash/g;
    s/\@ROCKSDB_GIT_DATE\@/$rocksdb_git_date/g;
    print $out $_;
  }

  # Close both files
  close $in;
  close $out;

  # Copy the temporary file to the original and then delete it
  copy $outfile, $infile or
      die "Unable to copy temp file ($outfile) on top of original ($infile)";
  unlink $outfile;
}

main(@ARGV);

=head1 NAME

githash.pl - Generate the mysql_githash.h file for MySQL

=head1 SYNOPSIS

githash.pl [options]

  Options:
    --help                        Brief help message
    --git_root=<path>             Path to the root of the MySQL git repository
    --file=<file>                 File to update with the git hashes and dates
    --mysql_githash=<hash_str>    Optional git hash to use for MySQL
    --mysql_gitdate=<date_str>    Optional git date to use for MySQL
    --rocksdb_githash=<hash_str>  Optional git hash to use for RocksDB
    --rocksdb_gitdate=<date_str>  Optional git date to use for RocksDB

=head1 OPTIONS

=over 4

=item B<--help>

Print a brief help message list all the options and exits

=item B<--git_root>

Supplies the path to the root git repository.  If the optional hashes and
dates are not supplied this script will call 'git log' in this location to get
the hashes and dates.

=item B<--file>

Specifies the file to update.  This file will be scanned for the following
markers, which will be replaced by the corresponding hash or date:

  @MYSQL_GIT_HASH@
  @MYSQL_GIT_DATE@
  @ROCKSDB_GIT_HASH@
  @ROCKSDB_GIT_DATE@

=item B<--mysql_githash>

Optional git hash for the MySQL repository.  If this is not specified the
script will use "git log" to query the repository.  If one of the hashes or
dates is supplied, all of them must be supplied.

=item B<--mysql_gitdate>

Optional git date for the MySQL repository.  If this is not specified the
script will use "git log" to query the repository.  If one of the hashes or
dates is supplied, all of them must be supplied.

=item B<--rocksdb_githash>

Optional git hash for the RocksDB repository.  If this is not specified the
script will use "git log" to query the repository.  If one of the hashes or
dates is supplied, all of them must be supplied.

=item B<--rocksdb_gitdate>

Optional git date for the RocksDB repository.  If this is not specified the
script will use "git log" to query the repository.  If one of the hashes or
dates is supplied, all of them must be supplied.

=back

=head1 DESCRIPTION

B<This program> will take the git hashes and dates (either supplied via
parameters or retrieved from 'git log') and update the specified file with the
values.

=cut


#!/usr/bin/perl

# Copyright (c) 2002 MySQL AB, 2009 Sun Microsystems, Inc.
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301  USA

die "No files specified\n" unless $ARGV[0];

$ctags="exctags -x -f - --c-types=f -u";

sub get_tag {
  local $.; local $_=<TAGS>;
  ($symbol, $line)= /^(.*\S)\s+function\s+(\d+)/;
  $symbol=$1 if /[\s*]([^\s*]+)\s*\(/;
  $line=1e50 unless $line;
}

while($src=shift)
{
  warn "==> $src\n";

  $dst=$src.$$;
  open(TAGS, "$ctags $src|") || die "Cannot exec('$ctags $src'): $!";
  open(SRC, "<$src") || die "Cannot open $src: $!";
  open(DST, ">$dst") || die "Cannot create $dst: $!";
  select DST;

  &get_tag;
  $in_func=0;
  while(<SRC>)
  {
    my $orig=$_;
    if ($in_func)
    {
      if (/\breturn\b/ && !/\/\*.*\breturn\b.*\*\// && !/;/ )
      {
        $_.=<SRC> until /;/;
      }
      s/(?<=\s)return\s*;/DBUG_VOID_RETURN;/;
      s/(?<=\s)return\s*(.+)\s*;/DBUG_RETURN(\1);/s;
      $ret_line=$. if /DBUG_(VOID_)?RETURN/; #{{
      print "$tab  DBUG_VOID_RETURN;\n" if /^$tab}/ && $ret_line < $.-1;
      $in_func=0 if /^$tab}/;
      warn "$src:".($.-1)."\t$orig" if /\breturn\b/;
    }
    print;
    next if $. < $line;
    die "Something wrong: \$.=$., \$line=$line, \$symbol=$symbol\n" if $. > $line;
    &get_tag && next if /^\s*inline /;
    print $_=<SRC> until /{/; $tab=$`;
    &get_tag && next if /}/; # skip one-liners
    $semicolon=1;
    while(<SRC>)
    {
      $skip=!$semicolon;
      $semicolon= /;\s*$/;
      print && next if $skip ||
        (/^\s+\w+((::\w+)?|<\w+>)\s+\**\w+/ && !/^\s*return\b/);
      last if /DBUG_ENTER/;
      print "$tab  DBUG_ENTER(\"$symbol\");\n";
      print "\n" unless $_ eq "\n";
      last;
    }
    $in_func=1;
    &get_tag;
    redo;
  }
  close SRC;
  close DST;
  close TAGS;
  unlink("$src.orig");
  rename($src, "$src.orig") || die "Cannot rename $src to $src.orig: $!";
  rename($dst, $src) || die "Cannot rename $dst to $src: $!";
}

warn "All done!\n";


#!/usr/bin/perl

die <<EEE unless @ARGV;
Usage: $0 func1 [func2 [ ...] ]

This filter (stdin->stdout) removes lines from dbug trace that were generated
by specified functions and all functions down the call stack. Produces the
same effect as if the original source had DBUG_PUSH(""); right after
DBUG_ENTER() and DBUG_POP(); right before DBUG_RETURN in every such a function.
EEE

$re=join('|', @ARGV);
$skip='';

while(<STDIN>) {
  print unless $skip;
  next unless /^(?:.*: )*((?:\| )*)([<>])($re)\n/o;
  if ($2 eq '>') {
    $skip=$1.$3 unless $skip;
    next;
  }
  next if $skip ne $1.$3;
  $skip='';
  print;
}


#!/usr/bin/env perl

#
#  A driver program to test DBUG features - runs tests (shell commands)
#  from the end of file to invoke tests.c, which does the real dbug work.
#

use Test::More;

$exe=$0;

die unless $exe =~ s/(tests)-t(\.exe)?$/$1$2 /;

# load tests
@tests=();
while (<DATA>) {
  if (/^% \.\/tests /) {
    push @tests, [ $' ]
  } elsif (/^#/) {
    next;
  } else {
    push @{$tests[$#tests]}, $_
  }
}

plan skip_all => "because dbug is disabled" if system $exe;

plan tests => scalar(@tests);

for (@tests) {
  $t=$exe . shift @$_;
  chomp($t);
  open F, '-|',  $t or die "open($t|): $!";
  local $";
  $out=join($", <F>); close(F);
  # special cases are handled here:
  $out =~ s/Memory: 0x[0-9A-Fa-f]+/Memory: 0x####/g if $t =~ /dump/;
  # compare ("\n" at the beginning makes better output in case of errors)
  is("\n$out","\n@$_", $t);
}

__DATA__
% ./tests -#d
func2: info: s=ok
=> execute
=> evaluate: ON
=> evaluate_if: OFF
main: explain: dbug explained: d
func2: info: s=ok
% ./tests d,ret3
=> evaluate: OFF
=> evaluate_if: OFF
#
## Testing negative lists
#
% ./tests d:-d,ret3
func2: info: s=ko
=> execute
=> evaluate: ON
=> evaluate_if: OFF
main: explain: dbug explained: d:-d,ret3
func2: info: s=ko
% ./tests t:-d,ret3
>main
| >func1
| | >func2
| | | >func3
| | | <func3
| | <func2
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
| >func2
| | >func3
| | <func3
| <func2
<main
% ./tests t:d,info:-d,ret3
>main
| >func1
| | >func2
| | | >func3
| | | <func3
| | | info: s=ko
| | <func2
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
| >func2
| | >func3
| | <func3
| | info: s=ko
| <func2
<main
% ./tests t:d,info:-d,ret3:-f,func2
>main
| >func1
| | | >func3
| | | <func3
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
| | >func3
| | <func3
<main
% ./tests t:d,info:-d,ret3:-f,func2 d,evaluate
=> evaluate: ON
=> evaluate_if: OFF
% ./tests t:d,info:-d,ret3:-f,func2 d,evaluate_if
=> evaluate: OFF
=> evaluate_if: ON
% ./tests t:d:-d,ret3:-f,func2 d,evaluate_if
=> evaluate: OFF
=> evaluate_if: ON
% ./tests t:d:-d,ret3:-f,func2
>main
| >func1
| | | >func3
| | | <func3
| <func1
=> execute
=> evaluate: ON
=> evaluate_if: OFF
| explain: dbug explained: d:-d,ret3:f:-f,func2:t
| | >func3
| | <func3
<main
#
## Adding incremental settings to the brew
#
% ./tests t:d:-d,ret3:-f,func2 +d,evaluate_if
>main
| >func1
| | | >func3
| | | <func3
| <func1
=> evaluate: OFF
=> evaluate_if: ON
| | >func3
| | <func3
<main
#
## DBUG_DUMP
#
% ./tests t:d:-d,ret3:f:-f,func2 +d,dump
>main
| >func1
| | | >func3
| | | <func3
| <func1
| dump: Memory: 0x####  Bytes: (27)
64 2C 64 75 6D 70 3A 2D 64 2C 72 65 74 33 3A 66 3A 2D 66 2C 66 75 6E 63 32 3A
74
=> evaluate: OFF
=> evaluate_if: OFF
| | >func3
| | <func3
<main
% ./tests t:d:-d,ret3:f:-f,func2 +d,dump
>main
| >func1
| | | >func3
| | | <func3
| <func1
| dump: Memory: 0x####  Bytes: (27)
64 2C 64 75 6D 70 3A 2D 64 2C 72 65 74 33 3A 66 3A 2D 66 2C 66 75 6E 63 32 3A
74
=> evaluate: OFF
=> evaluate_if: OFF
| | >func3
| | <func3
<main
% ./tests t:d:-d,ret3:f:-f,func2:+d,dump
>main
| >func1
| | | >func3
| | | <func3
| <func1
| dump: Memory: 0x####  Bytes: (27)
64 2C 64 75 6D 70 3A 2D 64 2C 72 65 74 33 3A 66 3A 2D 66 2C 66 75 6E 63 32 3A
74
=> evaluate: OFF
=> evaluate_if: OFF
| | >func3
| | <func3
<main
% ./tests t:d:-d,ret3:f:-f,func2 +d,dump,explain
>main
| >func1
| | | >func3
| | | <func3
| <func1
| dump: Memory: 0x####  Bytes: (35)
64 2C 64 75 6D 70 2C 65 78 70 6C 61 69 6E 3A 2D 64 2C 72 65 74 33 3A 66 3A 2D
66 2C 66 75 6E 63 32 3A 74
=> evaluate: OFF
=> evaluate_if: OFF
| explain: dbug explained: d,dump,explain:-d,ret3:f:-f,func2:t
| | >func3
| | <func3
<main
% ./tests t:d:-d,ret3:f:-f,func2 +d,dump,explain:P
dbug: >main
dbug-tests: | >func1
dbug-tests: | | | >func3
dbug-tests: | | | <func3
dbug-tests: | <func1
dbug-tests: | dump: Memory: 0x####  Bytes: (37)
64 2C 64 75 6D 70 2C 65 78 70 6C 61 69 6E 3A 2D 64 2C 72 65 74 33 3A 66 3A 2D
66 2C 66 75 6E 63 32 3A 50 3A 74
=> evaluate: OFF
=> evaluate_if: OFF
dbug-tests: | explain: dbug explained: d,dump,explain:-d,ret3:f:-f,func2:P:t
dbug-tests: | | >func3
dbug-tests: | | <func3
dbug-tests: <main
% ./tests t:d:-d,ret3:f:-f,func2 +d,dump,explain:P:F
dbug:        tests.c: >main
dbug-tests:        tests.c: | >func1
dbug-tests:        tests.c: | | | >func3
dbug-tests:        tests.c: | | | <func3
dbug-tests:        tests.c: | <func1
dbug-tests:        tests.c: | dump: Memory: 0x####  Bytes: (39)
64 2C 64 75 6D 70 2C 65 78 70 6C 61 69 6E 3A 2D 64 2C 72 65 74 33 3A 66 3A 2D
66 2C 66 75 6E 63 32 3A 46 3A 50 3A 74
=> evaluate: OFF
=> evaluate_if: OFF
dbug-tests:        tests.c: | explain: dbug explained: d,dump,explain:-d,ret3:f:-f,func2:F:P:t
dbug-tests:        tests.c: | | >func3
dbug-tests:        tests.c: | | <func3
dbug-tests:        tests.c: <main
#
## DBUG_EXPLAIN, DBUG_PUSH, DBUG_POP, DBUG_SET
#
% ./tests t:d:-d,ret3:f:-f,func2
>main
| >func1
| | | >func3
| | | <func3
| <func1
=> execute
=> evaluate: ON
=> evaluate_if: OFF
| explain: dbug explained: d:-d,ret3:f:-f,func2:t
| | >func3
| | <func3
<main
% ./tests t:d:-d,ret3
>main
| >func1
| | >func2
| | | >func3
| | | <func3
| | | info: s=ko
| | <func2
| <func1
=> execute
=> evaluate: ON
=> evaluate_if: OFF
| explain: dbug explained: d:-d,ret3:t
| >func2
| | >func3
| | <func3
| | info: s=ko
| <func2
<main
% ./tests d,info:-d,ret3:d,push
func2: info: s=ko
=> evaluate: OFF
=> evaluate_if: OFF
| >func2
| | >func3
| | <func3
| | info: s=ko
| <func2
<main
% ./tests d,info:-d,ret3:d,push,explain
func2: info: s=ko
=> evaluate: OFF
=> evaluate_if: OFF
| explain: dbug explained: d,info,push,explain:-d,ret3:t
| >func2
| | >func3
| | <func3
| | info: s=ko
| <func2
<main
% ./tests d,info:-d,ret3:d,explain
func2: info: s=ko
=> evaluate: OFF
=> evaluate_if: OFF
main: explain: dbug explained: d,info,explain:-d,ret3
func2: info: s=ko
% ./tests d,info:-d,ret3:d,explain,pop
func2: info: s=ko
=> evaluate: OFF
=> evaluate_if: OFF
% ./tests d,info:-d,ret3:d,explain t:d,pop
>main
| >func1
| | >func2
| | | >func3
| | | <func3
| | <func2
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
main: explain: dbug explained: d,info,explain:-d,ret3
func2: info: s=ko
% ./tests d,info:-d,ret3:d,explain,pop +t
>main
| >func1
| | >func2
| | | >func3
| | | <func3
| | | info: s=ko
| | <func2
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
main: explain: dbug explained: d,info,explain,pop:-d,ret3
func2: info: s=ko
% ./tests d,info:-d,ret3:d,explain,set
func2: info: s=ko
=> evaluate: OFF
=> evaluate_if: OFF
       tests.c: main: explain: dbug explained: d,info,explain,set:-d,ret3:F
       tests.c: func2: info: s=ko
% ./tests d,info:-d,ret3:d,explain,set:t
>main
| >func1
| | >func2
| | | >func3
| | | <func3
| | | info: s=ko
| | <func2
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
       tests.c: | explain: dbug explained: d,info,explain,set:-d,ret3:F:t
       tests.c: | >func2
       tests.c: | | >func3
       tests.c: | | <func3
       tests.c: | | info: s=ko
       tests.c: | <func2
       tests.c: <main
% ./tests t d,info:-d,ret3:d,explain,set:t
>main
| >func1
| | >func2
| | | >func3
| | | <func3
| | | info: s=ko
| | <func2
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
       tests.c: | explain: dbug explained: d,info,explain,set:-d,ret3:F:t
       tests.c: | >func2
       tests.c: | | >func3
       tests.c: | | <func3
       tests.c: | | info: s=ko
       tests.c: | <func2
       tests.c: <main
% ./tests t d,info:-d,ret3:d,explain,set,pop
func2: info: s=ko
=> evaluate: OFF
=> evaluate_if: OFF
| >func2
| | >func3
| | <func3
| <func2
<main
% ./tests t:f,func2
| | >func2
| | <func2
=> evaluate: OFF
=> evaluate_if: OFF
| >func2
| <func2
#
## Testing SUBDIR rules
#
% ./tests t:-f,func2/:d
>main
| >func1
| <func1
=> execute
=> evaluate: ON
=> evaluate_if: OFF
| explain: dbug explained: d:f:-f,func2/:t
<main
% ./tests t:f,func1/:d
| >func1
| | >func2
| | | >func3
| | | <func3
| | | info: s=ok
| | <func2
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
% ./tests t:f,main/:d,pop
>main
| >func1
| | >func2
| | | >func3
| | | <func3
| | <func2
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
% ./tests f,main/:d,push
=> evaluate: OFF
=> evaluate_if: OFF
| >func2
| | >func3
| | <func3
| <func2
<main
#
## Testing FixTraceFlags() - when we need to traverse the call stack
# (these tests fail with FixTraceFlags() disabled)
#
# delete the INCLUDE rule up the stack
% ./tests t:f,func1/ --push1=t:f,func3/
| >func1
| | >func2
| | | >func3
| | | <func3
| | <func2
=> push1
=> evaluate: OFF
=> evaluate_if: OFF
| | >func3
| | <func3
# delete the EXCLUDE rule up the stack
% ./tests t:-f,func1/ --push1=t
>main
=> push1
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
| >func2
| | >func3
| | <func3
| <func2
<main
# add the INCLUDE rule up the stack
% ./tests t:f,func3 --push1=t:f,main/
| | | >func3
| | | <func3
=> push1
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
| >func2
| | >func3
| | <func3
| <func2
<main
# add the EXCLUDE rule up the stack
% ./tests t --push1=t:-f,main/
>main
| >func1
| | >func2
| | | >func3
| | | <func3
| | <func2
=> push1
=> evaluate: OFF
=> evaluate_if: OFF
# change the defaults
% ./tests t:f,func3 --push1=t
| | | >func3
| | | <func3
=> push1
| <func1
=> evaluate: OFF
=> evaluate_if: OFF
| >func2
| | >func3
| | <func3
| <func2
<main
# repeated keyword
% ./tests d:-d,info,info
=> execute
=> evaluate: ON
=> evaluate_if: OFF
main: explain: dbug explained: d:-d,info
% ./tests d:-d,info/,info
=> execute
=> evaluate: ON
=> evaluate_if: OFF
main: explain: dbug explained: d:-d,info/


#!/usr/bin/perl

# Copyright (C) 2006 MySQL AB
# Use is subject to license terms
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA

#
# This script generates defines for all functions
# in yassl/include/openssl/ so they are renamed to
# ya<old_function_name>. Hopefully that is unique enough.
#
# The script is to be run manually when we import
# a new version of yaSSL
#

# Find all functions in "input" and add macros
# to prefix/rename them into "output
sub generate_prefix($$)
{
  my $input= shift;
  my $output= shift;
  open(IN, $input)
      or die("Can't open input file $input: $!");
  open(OUT, ">", $output)
    or mtr_error("Can't open output file $output: $!");

  while (<IN>)
  {
    chomp;

    if ( /typedef/ )
    {
      next;
    }

    if ( /^\s*[a-zA-Z0-9*_ ]+\s+\*?([_a-zA-Z0-9]+)\s*\(/ )
    {
      print OUT "#define $1 ya$1\n";
    }
  }

  close OUT;
  close IN;
}

generate_prefix("ssl.h", "prefix_ssl.h");
generate_prefix("crypto.h", "prefix_crypto.h");