// Copyright (c) 1998-2007, Google Inc.
// All rights reserved.
// 
// Redistribution and use in source and binary forms, with or without
// modification, are permitted provided that the following conditions are
// met:
// 
//     * Redistributions of source code must retain the above copyright
// notice, this list of conditions and the following disclaimer.
//     * Redistributions in binary form must reproduce the above
// copyright notice, this list of conditions and the following disclaimer
// in the documentation and/or other materials provided with the
// distribution.
//     * Neither the name of Google Inc. nor the names of its
// contributors may be used to endorse or promote products derived from
// this software without specific prior written permission.
// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
// OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
// SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
// LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
// DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
// THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
// (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


#include "brpc/builtin/pprof_perl.h"

namespace brpc {

const char* pprof_perl() {
    return "#! /usr/bin/env perl\n"
        "use strict;\n"
        "use warnings;\n"
        "use Getopt::Long;\n"
        "use Cwd;\n"
        "use POSIX;\n"
        "\n"
        "my $PPROF_VERSION = \"2.0\";\n"
        "\n"
        "# These are the object tools we use which can come from a\n"
        "# user-specified location using --tools, from the PPROF_TOOLS\n"
        "# environment variable, or from the environment.\n"
        "my %obj_tool_map = (\n"
        "  \"objdump\" => \"objdump\",\n"
        "  \"nm\" => \"nm\",\n"
        "  \"addr2line\" => \"addr2line\",\n"
        "  \"c++filt\" => \"c++filt\",\n"
        "  ## ConfigureObjTools may add architecture-specific entries:\n"
        "  #\"nm_pdb\" => \"nm-pdb\",       # for reading windows (PDB-format) executables\n"
        "  #\"addr2line_pdb\" => \"addr2line-pdb\",                                # ditto\n"
        "  #\"otool\" => \"otool\",         # equivalent of objdump on OS X\n"
        ");\n"
        "# NOTE: these are lists, so you can put in commandline flags if you want.\n"
        "my @DOT = (\"dot\");          # leave non-absolute, since it may be in /usr/local\n"
        "my @GV = (\"gv\");\n"
        "my @EVINCE = (\"evince\");    # could also be xpdf or perhaps acroread\n"
        "my @KCACHEGRIND = (\"kcachegrind\");\n"
        "my @PS2PDF = (\"ps2pdf\");\n"
        "# These are used for dynamic profiles\n"
        "my @URL_FETCHER = (\"curl\", \"-s\");\n"
        "\n"
        "# These are the web pages that servers need to support for dynamic profiles\n"
        "my $HEAP_PAGE = \"/pprof/heap\";\n"
        "my $PROFILE_PAGE = \"/pprof/profile\";   # must support cgi-param \"?seconds=#\"\n"
        "my $PMUPROFILE_PAGE = \"/pprof/pmuprofile(?:\\\\?.*)?\"; # must support cgi-param\n"
        "                                                # ?seconds=#&event=x&period=n\n"
        "my $GROWTH_PAGE = \"/pprof/growth\";\n"
        "my $CONTENTION_PAGE = \"/pprof/contention\";\n"
        "my $WALL_PAGE = \"/pprof/wall(?:\\\\?.*)?\";  # accepts options like namefilter\n"
        "my $FILTEREDPROFILE_PAGE = \"/pprof/filteredprofile(?:\\\\?.*)?\";\n"
        "my $CENSUSPROFILE_PAGE = \"/pprof/censusprofile(?:\\\\?.*)?\"; # must support "
        "cgi-param\n"
        "                                                       # \"?seconds=#\",\n"
        "                                                       # \"?tags_regexp=#\" and\n"
        "                                                       # \"?type=#\".\n"
        "my $SYMBOL_PAGE = \"/pprof/symbol\";     # must support symbol lookup via POST\n"
        "my $PROGRAM_NAME_PAGE = \"/pprof/cmdline\";\n"
        "\n"
        "# These are the web pages that can be named on the command line.\n"
        "# All the alternatives must begin with /.\n"
        "my $PROFILES = \"($HEAP_PAGE|$PROFILE_PAGE|$PMUPROFILE_PAGE|\" .\n"
        "               \"$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|\" .\n"
        "               \"$FILTEREDPROFILE_PAGE|$CENSUSPROFILE_PAGE)\";\n"
        "\n"
        "# default binary name\n"
        "my $UNKNOWN_BINARY = \"(unknown)\";\n"
        "\n"
        "# There is a pervasive dependency on the length (in hex characters,\n"
        "# i.e., nibbles) of an address, distinguishing between 32-bit and\n"
        "# 64-bit profiles.  To err on the safe size, default to 64-bit here:\n"
        "my $address_length = 16;\n"
        "\n"
        "my $dev_null = \"/dev/null\";\n"
        "if (! -e $dev_null && $^O =~ /MSWin/) {    # $^O is the OS perl was built for\n"
        "  $dev_null = \"nul\";\n"
        "}\n"
        "\n"
        "# A list of paths to search for shared object files\n"
        "my @prefix_list = ();\n"
        "\n"
        "# Special routine name that should not have any symbols.\n"
        "# Used as separator to parse \"addr2line -i\" output.\n"
        "my $sep_symbol = '_fini';\n"
        "my $sep_address = undef;\n"
        "\n"
        "my @stackTraces;\n"
        "\n"
        "##### Argument parsing #####\n"
        "\n"
        "sub usage_string {\n"
        "  return <<EOF;\n"
        "Usage:\n"
        "$0 [options] <program> <profiles>\n"
        "   <profiles> is a space separated list of profile names.\n"
        "$0 [options] <symbolized-profiles>\n"
        "   <symbolized-profiles> is a list of profile files where each file contains\n"
        "   the necessary symbol mappings  as well as profile data (likely generated\n"
        "   with --raw).\n"
        "$0 [options] <profile>\n"
        "   <profile> is a remote form.  Symbols are obtained from host:port$SYMBOL_PAGE\n"
        "   Each name can be:\n"
        "   /path/to/profile        - a path to a profile file\n"
        "   host:port[/<service>]   - a location of a service to get profile from\n"
        "   The /<service> can be $HEAP_PAGE, $PROFILE_PAGE, /pprof/pmuprofile,\n"
        "                         $GROWTH_PAGE, $CONTENTION_PAGE, /pprof/wall,\n"
        "                         $CENSUSPROFILE_PAGE, or /pprof/filteredprofile.\n"
        "   For instance:\n"
        "     $0 http://myserver.com:80$HEAP_PAGE\n"
        "   If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profiling).\n"
        "$0 --symbols <program>\n"
        "   Maps addresses to symbol names.  In this mode, stdin should be a\n"
        "   list of library mappings, in the same format as is found in the heap-\n"
        "   and cpu-profile files (this loosely matches that of /proc/self/maps\n"
        "   on linux), followed by a list of hex addresses to map, one per line.\n"
        "   For more help with querying remote servers, including how to add the\n"
        "   necessary server-side support code, see this filename (or one like it):\n"
        "   /usr/doc/gperftools-$PPROF_VERSION/pprof_remote_servers.html\n"
        "Options:\n"
        "   --cum               Sort by cumulative data\n"
        "   --base=<base>       Subtract <base> from <profile> before display\n"
        "   --interactive       Run in interactive mode (interactive \"help\" gives help) "
        "[default]\n"
        "   --seconds=<n>       Length of time for dynamic profiles [default=30 secs]\n"
        "   --add_lib=<file>    Read additional symbols and line info from the given library\n"
        "   --lib_prefix=<dir>  Comma separated list of library path prefixes\n"
        "   --no_strip_temp     Do not strip template arguments from function names\n"
        "Reporting Granularity:\n"
        "   --addresses         Report at address level\n"
        "   --lines             Report at source line level\n"
        "   --functions         Report at function level [default]\n"
        "   --files             Report at source file level\n"
        "Output type:\n"
        "   --text              Generate text report\n"
        "   --stacks            Generate stack traces similar to the heap profiler (requires "
        "--text)\n"
        "   --callgrind         Generate callgrind format to stdout\n"
        "   --gv                Generate Postscript and display\n"
        "   --evince            Generate PDF and display\n"
        "   --web               Generate SVG and display\n"
        "   --list=<regexp>     Generate source listing of matching routines\n"
        "   --disasm=<regexp>   Generate disassembly of matching routines\n"
        "   --symbols           Print demangled symbol names found at given addresses\n"
        "   --dot               Generate DOT file to stdout\n"
        "   --ps                Generate Postscript to stdout\n"
        "   --pdf               Generate PDF to stdout\n"
        "   --svg               Generate SVG to stdout\n"
        "   --gif               Generate GIF to stdout\n"
        "   --raw               Generate symbolized pprof data (useful with remote fetch)\n"
        "   --collapsed         Generate collapsed stacks for building flame graphs\n"
        "                       (see http://www.brendangregg.com/flamegraphs.html)\n"
        "Heap-Profile Options:\n"
        "   --inuse_space       Display in-use (mega)bytes [default]\n"
        "   --inuse_objects     Display in-use objects\n"
        "   --alloc_space       Display allocated (mega)bytes\n"
        "   --alloc_objects     Display allocated objects\n"
        "   --show_bytes        Display space in bytes\n"
        "   --drop_negative     Ignore negative differences\n"
        "Contention-profile options:\n"
        "   --total_delay       Display total delay at each region [default]\n"
        "   --contentions       Display number of delays at each region\n"
        "   --mean_delay        Display mean delay at each region\n"
        "Call-graph Options:\n"
        "   --nodecount=<n>     Show at most so many nodes [default=80]\n"
        "   --nodefraction=<f>  Hide nodes below <f>*total [default=.005]\n"
        "   --edgefraction=<f>  Hide edges below <f>*total [default=.001]\n"
        "   --maxdegree=<n>     Max incoming/outgoing edges per node [default=8]\n"
        "   --focus=<regexp>    Focus on nodes matching <regexp>\n"
        "   --ignore=<regexp>   Ignore nodes matching <regexp>\n"
        "   --scale=<n>         Set GV scaling [default=0]\n"
        "   --heapcheck         Make nodes with non-0 object counts\n"
        "                       (i.e. direct leak generators) more visible\n"
        "Miscellaneous:\n"
        "   --no-auto-signal-frm Automatically drop 2nd frame that is always same (cpu-only)\n"
        "                       (assuming that it is artifact of bad stack captures\n"
        "                        which include signal handler frames)\n"
        "   --show_addresses    Always show addresses when applicable\n"
        "   --tools=<prefix or binary:fullpath>[,...]   \\$PATH for object tool pathnames\n"
        "   --test              Run unit tests\n"
        "   --help              This message\n"
        "   --version           Version information\n"
        "Environment Variables:\n"
        "   PPROF_TMPDIR        Profiles directory. Defaults to \\$HOME/pprof\n"
        "   PPROF_TOOLS         Prefix for object tools pathnames\n"
        "Examples:\n"
        "$0 /bin/ls ls.prof\n"
        "                       Enters \"interactive\" mode\n"
        "$0 --text /bin/ls ls.prof\n"
        "                       Outputs one line per procedure\n"
        "$0 --web /bin/ls ls.prof\n"
        "                       Displays annotated call-graph in web browser\n"
        "$0 --gv /bin/ls ls.prof\n"
        "                       Displays annotated call-graph via 'gv'\n"
        "$0 --gv --focus=Mutex /bin/ls ls.prof\n"
        "                       Restricts to code paths including a .*Mutex.* entry\n"
        "$0 --gv --focus=Mutex --ignore=string /bin/ls ls.prof\n"
        "                       Code paths including Mutex but not string\n"
        "$0 --list=getdir /bin/ls ls.prof\n"
        "                       (Per-line) annotated source listing for getdir()\n"
        "$0 --disasm=getdir /bin/ls ls.prof\n"
        "                       (Per-PC) annotated disassembly for getdir()\n"
        "$0 http://localhost:1234/\n"
        "                       Enters \"interactive\" mode\n"
        "$0 --text localhost:1234\n"
        "                       Outputs one line per procedure for localhost:1234\n"
        "$0 --raw localhost:1234 > ./local.raw\n"
        "$0 --text ./local.raw\n"
        "                       Fetches a remote profile for later analysis and then\n"
        "                       analyzes it in text mode.\n"
        "EOF\n"
        "}\n"
        "\n"
        "sub version_string {\n"
        "  return <<EOF\n"
        "pprof (part of gperftools $PPROF_VERSION)\n"
        "Copyright 1998-2007 Google Inc.\n"
        "This is BSD licensed software; see the source for copying conditions\n"
        "and license information.\n"
        "There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A\n"
        "PARTICULAR PURPOSE.\n"
        "EOF\n"
        "}\n"
        "\n"
        "sub usage {\n"
        "  my $msg = shift;\n"
        "  print STDERR \"$msg\\n\\n\";\n"
        "  print STDERR usage_string();\n"
        "  exit(1);\n"
        "}\n"
        "\n"
        "sub Init() {\n"
        "  # Setup tmp-file name and handler to clean it up.\n"
        "  # We do this in the very beginning so that we can use\n"
        "  # error() and cleanup() function anytime here after.\n"
        "  $main::tmpfile_sym = \"/tmp/pprof$$.sym\";\n"
        "  $main::tmpfile_ps = \"/tmp/pprof$$\";\n"
        "  $main::next_tmpfile = 0;\n"
        "  $SIG{'INT'} = \\&sighandler;\n"
        "\n"
        "  # Cache from filename/linenumber to source code\n"
        "  $main::source_cache = ();\n"
        "\n"
        "  $main::opt_help = 0;\n"
        "  $main::opt_version = 0;\n"
        "  $main::opt_show_addresses = 0;\n"
        "  $main::opt_no_auto_signal_frames = 0;\n"
        "\n"
        "  $main::opt_cum = 0;\n"
        "  $main::opt_base = '';\n"
        "  $main::opt_addresses = 0;\n"
        "  $main::opt_lines = 0;\n"
        "  $main::opt_functions = 0;\n"
        "  $main::opt_files = 0;\n"
        "  $main::opt_lib_prefix = \"\";\n"
        "\n"
        "  $main::opt_text = 0;\n"
        "  $main::opt_stacks = 0;\n"
        "  $main::opt_callgrind = 0;\n"
        "  $main::opt_list = \"\";\n"
        "  $main::opt_disasm = \"\";\n"
        "  $main::opt_symbols = 0;\n"
        "  $main::opt_gv = 0;\n"
        "  $main::opt_evince = 0;\n"
        "  $main::opt_web = 0;\n"
        "  $main::opt_dot = 0;\n"
        "  $main::opt_ps = 0;\n"
        "  $main::opt_pdf = 0;\n"
        "  $main::opt_gif = 0;\n"
        "  $main::opt_svg = 0;\n"
        "  $main::opt_raw = 0;\n"
        "  $main::opt_collapsed = 0;\n"
        "\n"
        "  $main::opt_nodecount = 80;\n"
        "  $main::opt_nodefraction = 0.005;\n"
        "  $main::opt_edgefraction = 0.001;\n"
        "  $main::opt_maxdegree = 8;\n"
        "  $main::opt_focus = '';\n"
        "  $main::opt_ignore = '';\n"
        "  $main::opt_scale = 0;\n"
        "  $main::opt_heapcheck = 0;\n"
        "  $main::opt_seconds = 30;\n"
        "  $main::opt_lib = \"\";\n"
        "\n"
        "  $main::opt_inuse_space   = 0;\n"
        "  $main::opt_inuse_objects = 0;\n"
        "  $main::opt_alloc_space   = 0;\n"
        "  $main::opt_alloc_objects = 0;\n"
        "  $main::opt_show_bytes    = 0;\n"
        "  $main::opt_drop_negative = 0;\n"
        "  $main::opt_interactive   = 0;\n"
        "\n"
        "  $main::opt_total_delay = 0;\n"
        "  $main::opt_contentions = 0;\n"
        "  $main::opt_mean_delay = 0;\n"
        "\n"
        "  $main::opt_tools   = \"\";\n"
        "  $main::opt_debug   = 0;\n"
        "  $main::opt_test    = 0;\n"
        "\n"
        "  # Do not strip template argument in function names\n"
        "  $main::opt_no_strip_temp = 0;\n"
        "\n"
        "  # These are undocumented flags used only by unittests.\n"
        "  $main::opt_test_stride = 0;\n"
        "\n"
        "  # Are we using $SYMBOL_PAGE?\n"
        "  $main::use_symbol_page = 0;\n"
        "\n"
        "  # Files returned by TempName.\n"
        "  %main::tempnames = ();\n"
        "\n"
        "  # Type of profile we are dealing with\n"
        "  # Supported types:\n"
        "  #     cpu\n"
        "  #     heap\n"
        "  #     growth\n"
        "  #     contention\n"
        "  $main::profile_type = '';     # Empty type means \"unknown\"\n"
        "\n"
        "  GetOptions(\"help!\"          => \\$main::opt_help,\n"
        "             \"version!\"       => \\$main::opt_version,\n"
        "             \"show_addresses!\"=> \\$main::opt_show_addresses,\n"
        "             \"no-auto-signal-frm!\"=> \\$main::opt_no_auto_signal_frames,\n"
        "             \"cum!\"           => \\$main::opt_cum,\n"
        "             \"base=s\"         => \\$main::opt_base,\n"
        "             \"seconds=i\"      => \\$main::opt_seconds,\n"
        "             \"add_lib=s\"      => \\$main::opt_lib,\n"
        "             \"lib_prefix=s\"   => \\$main::opt_lib_prefix,\n"
        "             \"functions!\"     => \\$main::opt_functions,\n"
        "             \"lines!\"         => \\$main::opt_lines,\n"
        "             \"addresses!\"     => \\$main::opt_addresses,\n"
        "             \"files!\"         => \\$main::opt_files,\n"
        "             \"text!\"          => \\$main::opt_text,\n"
        "             \"stacks!\"        => \\$main::opt_stacks,\n"
        "             \"callgrind!\"     => \\$main::opt_callgrind,\n"
        "             \"list=s\"         => \\$main::opt_list,\n"
        "             \"disasm=s\"       => \\$main::opt_disasm,\n"
        "             \"symbols!\"       => \\$main::opt_symbols,\n"
        "             \"gv!\"            => \\$main::opt_gv,\n"
        "             \"evince!\"        => \\$main::opt_evince,\n"
        "             \"web!\"           => \\$main::opt_web,\n"
        "             \"dot!\"           => \\$main::opt_dot,\n"
        "             \"ps!\"            => \\$main::opt_ps,\n"
        "             \"pdf!\"           => \\$main::opt_pdf,\n"
        "             \"svg!\"           => \\$main::opt_svg,\n"
        "             \"gif!\"           => \\$main::opt_gif,\n"
        "             \"raw!\"           => \\$main::opt_raw,\n"
        "             \"collapsed!\"     => \\$main::opt_collapsed,\n"
        "             \"interactive!\"   => \\$main::opt_interactive,\n"
        "             \"nodecount=i\"    => \\$main::opt_nodecount,\n"
        "             \"nodefraction=f\" => \\$main::opt_nodefraction,\n"
        "             \"edgefraction=f\" => \\$main::opt_edgefraction,\n"
        "             \"maxdegree=i\"    => \\$main::opt_maxdegree,\n"
        "             \"focus=s\"        => \\$main::opt_focus,\n"
        "             \"ignore=s\"       => \\$main::opt_ignore,\n"
        "             \"scale=i\"        => \\$main::opt_scale,\n"
        "             \"heapcheck\"      => \\$main::opt_heapcheck,\n"
        "             \"inuse_space!\"   => \\$main::opt_inuse_space,\n"
        "             \"inuse_objects!\" => \\$main::opt_inuse_objects,\n"
        "             \"alloc_space!\"   => \\$main::opt_alloc_space,\n"
        "             \"alloc_objects!\" => \\$main::opt_alloc_objects,\n"
        "             \"show_bytes!\"    => \\$main::opt_show_bytes,\n"
        "             \"drop_negative!\" => \\$main::opt_drop_negative,\n"
        "             \"total_delay!\"   => \\$main::opt_total_delay,\n"
        "             \"contentions!\"   => \\$main::opt_contentions,\n"
        "             \"mean_delay!\"    => \\$main::opt_mean_delay,\n"
        "             \"tools=s\"        => \\$main::opt_tools,\n"
        "             \"no_strip_temp!\" => \\$main::opt_no_strip_temp,\n"
        "             \"test!\"          => \\$main::opt_test,\n"
        "             \"debug!\"         => \\$main::opt_debug,\n"
        "             # Undocumented flags used only by unittests:\n"
        "             \"test_stride=i\"  => \\$main::opt_test_stride,\n"
        "      ) || usage(\"Invalid option(s)\");\n"
        "\n"
        "  # Deal with the standard --help and --version\n"
        "  if ($main::opt_help) {\n"
        "    print usage_string();\n"
        "    exit(0);\n"
        "  }\n"
        "\n"
        "  if ($main::opt_version) {\n"
        "    print version_string();\n"
        "    exit(0);\n"
        "  }\n"
        "\n"
        "  # Disassembly/listing/symbols mode requires address-level info\n"
        "  if ($main::opt_disasm || $main::opt_list || $main::opt_symbols) {\n"
        "    $main::opt_functions = 0;\n"
        "    $main::opt_lines = 0;\n"
        "    $main::opt_addresses = 1;\n"
        "    $main::opt_files = 0;\n"
        "  }\n"
        "\n"
        "  # Check heap-profiling flags\n"
        "  if ($main::opt_inuse_space +\n"
        "      $main::opt_inuse_objects +\n"
        "      $main::opt_alloc_space +\n"
        "      $main::opt_alloc_objects > 1) {\n"
        "    usage(\"Specify at most on of --inuse/--alloc options\");\n"
        "  }\n"
        "\n"
        "  # Check output granularities\n"
        "  my $grains =\n"
        "      $main::opt_functions +\n"
        "      $main::opt_lines +\n"
        "      $main::opt_addresses +\n"
        "      $main::opt_files +\n"
        "      0;\n"
        "  if ($grains > 1) {\n"
        "    usage(\"Only specify one output granularity option\");\n"
        "  }\n"
        "  if ($grains == 0) {\n"
        "    $main::opt_functions = 1;\n"
        "  }\n"
        "\n"
        "  # Check output modes\n"
        "  my $modes =\n"
        "      $main::opt_text +\n"
        "      $main::opt_callgrind +\n"
        "      ($main::opt_list eq '' ? 0 : 1) +\n"
        "      ($main::opt_disasm eq '' ? 0 : 1) +\n"
        "      ($main::opt_symbols == 0 ? 0 : 1) +\n"
        "      $main::opt_gv +\n"
        "      $main::opt_evince +\n"
        "      $main::opt_web +\n"
        "      $main::opt_dot +\n"
        "      $main::opt_ps +\n"
        "      $main::opt_pdf +\n"
        "      $main::opt_svg +\n"
        "      $main::opt_gif +\n"
        "      $main::opt_raw +\n"
        "      $main::opt_collapsed +\n"
        "      $main::opt_interactive +\n"
        "      0;\n"
        "  if ($modes > 1) {\n"
        "    usage(\"Only specify one output mode\");\n"
        "  }\n"
        "  if ($modes == 0) {\n"
        "    if (-t STDOUT) {  # If STDOUT is a tty, activate interactive mode\n"
        "      $main::opt_interactive = 1;\n"
        "    } else {\n"
        "      $main::opt_text = 1;\n"
        "    }\n"
        "  }\n"
        "\n"
        "  if ($main::opt_test) {\n"
        "    RunUnitTests();\n"
        "    # Should not return\n"
        "    exit(1);\n"
        "  }\n"
        "\n"
        "  # Binary name and profile arguments list\n"
        "  $main::prog = \"\";\n"
        "  @main::pfile_args = ();\n"
        "\n"
        "  # Remote profiling without a binary (using $SYMBOL_PAGE instead)\n"
        "  if (@ARGV > 0) {\n"
        "    if (IsProfileURL($ARGV[0])) {\n"
        "      printf STDERR \"Using remote profile at $ARGV[0].\\n\";\n"
        "      $main::use_symbol_page = 1;\n"
        "    } elsif (IsSymbolizedProfileFile($ARGV[0])) {\n"
        "      $main::use_symbolized_profile = 1;\n"
        "      $main::prog = $UNKNOWN_BINARY;  # will be set later from the profile file\n"
        "    }\n"
        "  }\n"
        "\n"
        "  if ($main::use_symbol_page || $main::use_symbolized_profile) {\n"
        "    # We don't need a binary!\n"
        "    my %disabled = ('--lines' => $main::opt_lines,\n"
        "                    '--disasm' => $main::opt_disasm);\n"
        "    for my $option (keys %disabled) {\n"
        "      usage(\"$option cannot be used without a binary\") if $disabled{$option};\n"
        "    }\n"
        "    # Set $main::prog later...\n"
        "    scalar(@ARGV) || usage(\"Did not specify profile file\");\n"
        "  } elsif ($main::opt_symbols) {\n"
        "    # --symbols needs a binary-name (to run nm on, etc) but not profiles\n"
        "    $main::prog = shift(@ARGV) || usage(\"Did not specify program\");\n"
        "  } else {\n"
        "    $main::prog = shift(@ARGV) || usage(\"Did not specify program\");\n"
        "    scalar(@ARGV) || usage(\"Did not specify profile file\");\n"
        "  }\n"
        "\n"
        "  # Parse profile file/location arguments\n"
        "  foreach my $farg (@ARGV) {\n"
        "    if ($farg =~ m/(.*)\\@([0-9]+)(|\\/.*)$/ ) {\n"
        "      my $machine = $1;\n"
        "      my $num_machines = $2;\n"
        "      my $path = $3;\n"
        "      for (my $i = 0; $i < $num_machines; $i++) {\n"
        "        unshift(@main::pfile_args, \"$i.$machine$path\");\n"
        "      }\n"
        "    } else {\n"
        "      unshift(@main::pfile_args, $farg);\n"
        "    }\n"
        "  }\n"
        "\n"
        "  if ($main::use_symbol_page) {\n"
        "    unless (IsProfileURL($main::pfile_args[0])) {\n"
        "      error(\"The first profile should be a remote form to use $SYMBOL_PAGE\\n\");\n"
        "    }\n"
        "    CheckSymbolPage();\n"
        "    $main::prog = FetchProgramName();\n"
        "  } elsif (!$main::use_symbolized_profile) {  # may not need objtools!\n"
        "    ConfigureObjTools($main::prog)\n"
        "  }\n"
        "\n"
        "  # Break the opt_lib_prefix into the prefix_list array\n"
        "  @prefix_list = split (',', $main::opt_lib_prefix);\n"
        "\n"
        "  # Remove trailing / from the prefixes, in the list to prevent\n"
        "  # searching things like /my/path//lib/mylib.so\n"
        "  foreach (@prefix_list) {\n"
        "    s|/+$||;\n"
        "  }\n"
        "}\n"
        "\n"
        "sub Main() {\n"
        "  Init();\n"
        "  $main::collected_profile = undef;\n"
        "  @main::profile_files = ();\n"
        "  $main::op_time = time();\n"
        "\n"
        "  # Printing symbols is special and requires a lot less info that most.\n"
        "  if ($main::opt_symbols) {\n"
        "    PrintSymbols(*STDIN);   # Get /proc/maps and symbols output from stdin\n"
        "    return;\n"
        "  }\n"
        "\n"
        "  # Fetch all profile data\n"
        "  FetchDynamicProfiles();\n"
        "\n"
        "  # this will hold symbols that we read from the profile files\n"
        "  my $symbol_map = {};\n"
        "\n"
        "  # Read one profile, pick the last item on the list\n"
        "  my $data = ReadProfile($main::prog, pop(@main::profile_files));\n"
        "  my $profile = $data->{profile};\n"
        "  my $pcs = $data->{pcs};\n"
        "  my $libs = $data->{libs};   # Info about main program and shared libraries\n"
        "  $symbol_map = MergeSymbols($symbol_map, $data->{symbols});\n"
        "\n"
        "  # Add additional profiles, if available.\n"
        "  if (scalar(@main::profile_files) > 0) {\n"
        "    foreach my $pname (@main::profile_files) {\n"
        "      my $data2 = ReadProfile($main::prog, $pname);\n"
        "      $profile = AddProfile($profile, $data2->{profile});\n"
        "      $pcs = AddPcs($pcs, $data2->{pcs});\n"
        "      $symbol_map = MergeSymbols($symbol_map, $data2->{symbols});\n"
        "    }\n"
        "  }\n"
        "\n"
        "  # Subtract base from profile, if specified\n"
        "  if ($main::opt_base ne '') {\n"
        "    my $base = ReadProfile($main::prog, $main::opt_base);\n"
        "    $profile = SubtractProfile($profile, $base->{profile});\n"
        "    $pcs = AddPcs($pcs, $base->{pcs});\n"
        "    $symbol_map = MergeSymbols($symbol_map, $base->{symbols});\n"
        "  }\n"
        "\n"
        "  # Get total data in profile\n"
        "  my $total = TotalProfile($profile);\n"
        "\n"
        "  # Collect symbols\n"
        "  my $symbols;\n"
        "  if ($main::use_symbolized_profile) {\n"
        "    $symbols = FetchSymbols($pcs, $symbol_map);\n"
        "  } elsif ($main::use_symbol_page) {\n"
        "    $symbols = FetchSymbols($pcs);\n"
        "  } else {\n"
        "    # TODO(csilvers): $libs uses the /proc/self/maps data from profile1,\n"
        "    # which may differ from the data from subsequent profiles, especially\n"
        "    # if they were run on different machines.  Use appropriate libs for\n"
        "    # each pc somehow.\n"
        "    $symbols = ExtractSymbols($libs, $pcs);\n"
        "  }\n"
        "\n"
        "  # Remove uniniteresting stack items\n"
        "  $profile = RemoveUninterestingFrames($symbols, $profile);\n"
        "\n"
        "  # Focus?\n"
        "  if ($main::opt_focus ne '') {\n"
        "    $profile = FocusProfile($symbols, $profile, $main::opt_focus);\n"
        "  }\n"
        "\n"
        "  # Ignore?\n"
        "  if ($main::opt_ignore ne '') {\n"
        "    $profile = IgnoreProfile($symbols, $profile, $main::opt_ignore);\n"
        "  }\n"
        "\n"
        "  my $calls = ExtractCalls($symbols, $profile);\n"
        "\n"
        "  # Reduce profiles to required output granularity, and also clean\n"
        "  # each stack trace so a given entry exists at most once.\n"
        "  my $reduced = ReduceProfile($symbols, $profile);\n"
        "\n"
        "  # Get derived profiles\n"
        "  my $flat = FlatProfile($reduced);\n"
        "  my $cumulative = CumulativeProfile($reduced);\n"
        "\n"
        "  # Print\n"
        "  if (!$main::opt_interactive) {\n"
        "    if ($main::opt_disasm) {\n"
        "      PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm);\n"
        "    } elsif ($main::opt_list) {\n"
        "      PrintListing($total, $libs, $flat, $cumulative, $main::opt_list, 0);\n"
        "    } elsif ($main::opt_text) {\n"
        "      # Make sure the output is empty when have nothing to report\n"
        "      # (only matters when --heapcheck is given but we must be\n"
        "      # compatible with old branches that did not pass --heapcheck always):\n"
        "      if ($total != 0) {\n"
        "        printf(\"Total: %s %s\\n\", Unparse($total), Units());\n"
        "      }\n"
        "      if ($main::opt_stacks) {\n"
        "        printf(\"Stacks:\\n\\n\");\n"
        "        PrintStacksForText($symbols, $profile);\n"
        "      }\n"
        "      PrintText($symbols, $flat, $cumulative, -1);\n"
        "    } elsif ($main::opt_raw) {\n"
        "      PrintSymbolizedProfile($symbols, $profile, $main::prog);\n"
        "    } elsif ($main::opt_collapsed) {\n"
        "      PrintCollapsedStacks($symbols, $profile);\n"
        "    } elsif ($main::opt_callgrind) {\n"
        "      PrintCallgrind($calls);\n"
        "    } else {\n"
        "      if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {\n"
        "        if ($main::opt_gv) {\n"
        "          RunGV(TempName($main::next_tmpfile, \"ps\"), \"\");\n"
        "        } elsif ($main::opt_evince) {\n"
        "          RunEvince(TempName($main::next_tmpfile, \"pdf\"), \"\");\n"
        "        } elsif ($main::opt_web) {\n"
        "          my $tmp = TempName($main::next_tmpfile, \"svg\");\n"
        "          RunWeb($tmp);\n"
        "          # The command we run might hand the file name off\n"
        "          # to an already running browser instance and then exit.\n"
        "          # Normally, we'd remove $tmp on exit (right now),\n"
        "          # but fork a child to remove $tmp a little later, so that the\n"
        "          # browser has time to load it first.\n"
        "          delete $main::tempnames{$tmp};\n"
        "          if (fork() == 0) {\n"
        "            sleep 5;\n"
        "            unlink($tmp);\n"
        "            exit(0);\n"
        "          }\n"
        "        }\n"
        "      } else {\n"
        "        cleanup();\n"
        "        exit(1);\n"
        "      }\n"
        "    }\n"
        "  } else {\n"
        "    InteractiveMode($profile, $symbols, $libs, $total);\n"
        "  }\n"
        "\n"
        "  cleanup();\n"
        "  exit(0);\n"
        "}\n"
        "\n"
        "##### Entry Point #####\n"
        "\n"
        "Main();\n"
        "\n"
        "# Temporary code to detect if we're running on a Goobuntu system.\n"
        "# These systems don't have the right stuff installed for the special\n"
        "# Readline libraries to work, so as a temporary workaround, we default\n"
        "# to using the normal stdio code, rather than the fancier readline-based\n"
        "# code\n"
        "sub ReadlineMightFail {\n"
        "  if (-e '/lib/libtermcap.so.2') {\n"
        "    return 0;  # libtermcap exists, so readline should be okay\n"
        "  } else {\n"
        "    return 1;\n"
        "  }\n"
        "}\n"
        "\n"
        "sub RunGV {\n"
        "  my $fname = shift;\n"
        "  my $bg = shift;       # \"\" or \" &\" if we should run in background\n"
        "  if (!system(ShellEscape(@GV, \"--version\") . \" >$dev_null 2>&1\")) {\n"
        "    # Options using double dash are supported by this gv version.\n"
        "    # Also, turn on noantialias to better handle bug in gv for\n"
        "    # postscript files with large dimensions.\n"
        "    # TODO: Maybe we should not pass the --noantialias flag\n"
        "    # if the gv version is known to work properly without the flag.\n"
        "    system(ShellEscape(@GV, \"--scale=$main::opt_scale\", \"--noantialias\", $fname)\n"
        "           . $bg);\n"
        "  } else {\n"
        "    # Old gv version - only supports options that use single dash.\n"
        "    print STDERR ShellEscape(@GV, \"-scale\", $main::opt_scale) . \"\\n\";\n"
        "    system(ShellEscape(@GV, \"-scale\", \"$main::opt_scale\", $fname) . $bg);\n"
        "  }\n"
        "}\n"
        "\n"
        "sub RunEvince {\n"
        "  my $fname = shift;\n"
        "  my $bg = shift;       # \"\" or \" &\" if we should run in background\n"
        "  system(ShellEscape(@EVINCE, $fname) . $bg);\n"
        "}\n"
        "\n"
        "sub RunWeb {\n"
        "  my $fname = shift;\n"
        "  print STDERR \"Loading web page file:///$fname\\n\";\n"
        "\n"
        "  if (`uname` =~ /Darwin/) {\n"
        "    # OS X: open will use standard preference for SVG files.\n"
        "    system(\"/usr/bin/open\", $fname);\n"
        "    return;\n"
        "  }\n"
        "\n"
        "  if (`uname` =~ /MINGW/) {\n"
        "    # Windows(MinGW): open will use standard preference for SVG files.\n"
        "    system(\"cmd\", \"/c\", \"start\", $fname);\n"
        "    return;\n"
        "  }\n"
        "\n"
        "  # Some kind of Unix; try generic symlinks, then specific browsers.\n"
        "  # (Stop once we find one.)\n"
        "  # Works best if the browser is already running.\n"
        "  my @alt = (\n"
        "    \"/etc/alternatives/gnome-www-browser\",\n"
        "    \"/etc/alternatives/x-www-browser\",\n"
        "    \"google-chrome\",\n"
        "    \"firefox\",\n"
        "  );\n"
        "  foreach my $b (@alt) {\n"
        "    if (system($b, $fname) == 0) {\n"
        "      return;\n"
        "    }\n"
        "  }\n"
        "\n"
        "  print STDERR \"Could not load web browser.\\n\";\n"
        "}\n"
        "\n"
        "sub RunKcachegrind {\n"
        "  my $fname = shift;\n"
        "  my $bg = shift;       # \"\" or \" &\" if we should run in background\n"
        "  print STDERR \"Starting '@KCACHEGRIND \" . $fname . $bg . \"'\\n\";\n"
        "  system(ShellEscape(@KCACHEGRIND, $fname) . $bg);\n"
        "}\n"
        "\n"
        "\n"
        "##### Interactive helper routines #####\n"
        "\n"
        "sub InteractiveMode {\n"
        "  $| = 1;  # Make output unbuffered for interactive mode\n"
        "  my ($orig_profile, $symbols, $libs, $total) = @_;\n"
        "\n"
        "  print STDERR \"Welcome to pprof!  For help, type 'help'.\\n\";\n"
        "\n"
        "  # Use ReadLine if it's installed and input comes from a console.\n"
        "  if ( -t STDIN &&\n"
        "       !ReadlineMightFail() &&\n"
        "       defined(eval {require Term::ReadLine}) ) {\n"
        "    my $term = new Term::ReadLine 'pprof';\n"
        "    while ( defined ($_ = $term->readline('(pprof) '))) {\n"
        "      $term->addhistory($_) if /\\S/;\n"
        "      if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {\n"
        "        last;    # exit when we get an interactive command to quit\n"
        "      }\n"
        "    }\n"
        "  } else {       # don't have readline\n"
        "    while (1) {\n"
        "      print STDERR \"(pprof) \";\n"
        "      $_ = <STDIN>;\n"
        "      last if ! defined $_ ;\n"
        "      s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "\n"
        "      # Save some flags that might be reset by InteractiveCommand()\n"
        "      my $save_opt_lines = $main::opt_lines;\n"
        "\n"
        "      if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {\n"
        "        last;    # exit when we get an interactive command to quit\n"
        "      }\n"
        "\n"
        "      # Restore flags\n"
        "      $main::opt_lines = $save_opt_lines;\n"
        "    }\n"
        "  }\n"
        "}\n"
        "\n"
        "# Takes two args: orig profile, and command to run.\n"
        "# Returns 1 if we should keep going, or 0 if we were asked to quit\n"
        "sub InteractiveCommand {\n"
        "  my($orig_profile, $symbols, $libs, $total, $command) = @_;\n"
        "  $_ = $command;                # just to make future m//'s easier\n"
        "  if (!defined($_)) {\n"
        "    print STDERR \"\\n\";\n"
        "    return 0;\n"
        "  }\n"
        "  if (m/^\\s*quit/) {\n"
        "    return 0;\n"
        "  }\n"
        "  if (m/^\\s*help/) {\n"
        "    InteractiveHelpMessage();\n"
        "    return 1;\n"
        "  }\n"
        "  # Clear all the mode options -- mode is controlled by \"$command\"\n"
        "  $main::opt_text = 0;\n"
        "  $main::opt_callgrind = 0;\n"
        "  $main::opt_disasm = 0;\n"
        "  $main::opt_list = 0;\n"
        "  $main::opt_gv = 0;\n"
        "  $main::opt_evince = 0;\n"
        "  $main::opt_cum = 0;\n"
        "\n"
        "  if (m/^\\s*(text|top)(\\d*)\\s*(.*)/) {\n"
        "    $main::opt_text = 1;\n"
        "\n"
        "    my $line_limit = ($2 ne \"\") ? int($2) : 10;\n"
        "\n"
        "    my $routine;\n"
        "    my $ignore;\n"
        "    ($routine, $ignore) = ParseInteractiveArgs($3);\n"
        "\n"
        "    my $profile = ProcessProfile($total, $orig_profile, $symbols, \"\", $ignore);\n"
        "    my $reduced = ReduceProfile($symbols, $profile);\n"
        "\n"
        "    # Get derived profiles\n"
        "    my $flat = FlatProfile($reduced);\n"
        "    my $cumulative = CumulativeProfile($reduced);\n"
        "\n"
        "    PrintText($symbols, $flat, $cumulative, $line_limit);\n"
        "    return 1;\n"
        "  }\n"
        "  if (m/^\\s*callgrind\\s*([^ \\n]*)/) {\n"
        "    $main::opt_callgrind = 1;\n"
        "\n"
        "    # Get derived profiles\n"
        "    my $calls = ExtractCalls($symbols, $orig_profile);\n"
        "    my $filename = $1;\n"
        "    if ( $1 eq '' ) {\n"
        "      $filename = TempName($main::next_tmpfile, \"callgrind\");\n"
        "    }\n"
        "    PrintCallgrind($calls, $filename);\n"
        "    if ( $1 eq '' ) {\n"
        "      RunKcachegrind($filename, \" & \");\n"
        "      $main::next_tmpfile++;\n"
        "    }\n"
        "\n"
        "    return 1;\n"
        "  }\n"
        "  if (m/^\\s*(web)?list\\s*(.+)/) {\n"
        "    my $html = (defined($1) && ($1 eq \"web\"));\n"
        "    $main::opt_list = 1;\n"
        "\n"
        "    my $routine;\n"
        "    my $ignore;\n"
        "    ($routine, $ignore) = ParseInteractiveArgs($2);\n"
        "\n"
        "    my $profile = ProcessProfile($total, $orig_profile, $symbols, \"\", $ignore);\n"
        "    my $reduced = ReduceProfile($symbols, $profile);\n"
        "\n"
        "    # Get derived profiles\n"
        "    my $flat = FlatProfile($reduced);\n"
        "    my $cumulative = CumulativeProfile($reduced);\n"
        "\n"
        "    PrintListing($total, $libs, $flat, $cumulative, $routine, $html);\n"
        "    return 1;\n"
        "  }\n"
        "  if (m/^\\s*disasm\\s*(.+)/) {\n"
        "    $main::opt_disasm = 1;\n"
        "\n"
        "    my $routine;\n"
        "    my $ignore;\n"
        "    ($routine, $ignore) = ParseInteractiveArgs($1);\n"
        "\n"
        "    # Process current profile to account for various settings\n"
        "    my $profile = ProcessProfile($total, $orig_profile, $symbols, \"\", $ignore);\n"
        "    my $reduced = ReduceProfile($symbols, $profile);\n"
        "\n"
        "    # Get derived profiles\n"
        "    my $flat = FlatProfile($reduced);\n"
        "    my $cumulative = CumulativeProfile($reduced);\n"
        "\n"
        "    PrintDisassembly($libs, $flat, $cumulative, $routine);\n"
        "    return 1;\n"
        "  }\n"
        "  if (m/^\\s*(gv|web|evince)\\s*(.*)/) {\n"
        "    $main::opt_gv = 0;\n"
        "    $main::opt_evince = 0;\n"
        "    $main::opt_web = 0;\n"
        "    if ($1 eq \"gv\") {\n"
        "      $main::opt_gv = 1;\n"
        "    } elsif ($1 eq \"evince\") {\n"
        "      $main::opt_evince = 1;\n"
        "    } elsif ($1 eq \"web\") {\n"
        "      $main::opt_web = 1;\n"
        "    }\n"
        "\n"
        "    my $focus;\n"
        "    my $ignore;\n"
        "    ($focus, $ignore) = ParseInteractiveArgs($2);\n"
        "\n"
        "    # Process current profile to account for various settings\n"
        "    my $profile = ProcessProfile($total, $orig_profile, $symbols,\n"
        "                                 $focus, $ignore);\n"
        "    my $reduced = ReduceProfile($symbols, $profile);\n"
        "\n"
        "    # Get derived profiles\n"
        "    my $flat = FlatProfile($reduced);\n"
        "    my $cumulative = CumulativeProfile($reduced);\n"
        "\n"
        "    if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {\n"
        "      if ($main::opt_gv) {\n"
        "        RunGV(TempName($main::next_tmpfile, \"ps\"), \" &\");\n"
        "      } elsif ($main::opt_evince) {\n"
        "        RunEvince(TempName($main::next_tmpfile, \"pdf\"), \" &\");\n"
        "      } elsif ($main::opt_web) {\n"
        "        RunWeb(TempName($main::next_tmpfile, \"svg\"));\n"
        "      }\n"
        "      $main::next_tmpfile++;\n"
        "    }\n"
        "    return 1;\n"
        "  }\n"
        "  if (m/^\\s*$/) {\n"
        "    return 1;\n"
        "  }\n"
        "  print STDERR \"Unknown command: try 'help'.\\n\";\n"
        "  return 1;\n"
        "}\n"
        "\n"
        "\n"
        "sub ProcessProfile {\n"
        "  my $total_count = shift;\n"
        "  my $orig_profile = shift;\n"
        "  my $symbols = shift;\n"
        "  my $focus = shift;\n"
        "  my $ignore = shift;\n"
        "\n"
        "  # Process current profile to account for various settings\n"
        "  my $profile = $orig_profile;\n"
        "  printf(\"Total: %s %s\\n\", Unparse($total_count), Units());\n"
        "  if ($focus ne '') {\n"
        "    $profile = FocusProfile($symbols, $profile, $focus);\n"
        "    my $focus_count = TotalProfile($profile);\n"
        "    printf(\"After focusing on '%s': %s %s of %s (%0.1f%%)\\n\",\n"
        "           $focus,\n"
        "           Unparse($focus_count), Units(),\n"
        "           Unparse($total_count), ($focus_count*100.0) / $total_count);\n"
        "  }\n"
        "  if ($ignore ne '') {\n"
        "    $profile = IgnoreProfile($symbols, $profile, $ignore);\n"
        "    my $ignore_count = TotalProfile($profile);\n"
        "    printf(\"After ignoring '%s': %s %s of %s (%0.1f%%)\\n\",\n"
        "           $ignore,\n"
        "           Unparse($ignore_count), Units(),\n"
        "           Unparse($total_count),\n"
        "           ($ignore_count*100.0) / $total_count);\n"
        "  }\n"
        "\n"
        "  return $profile;\n"
        "}\n"
        "\n"
        "sub InteractiveHelpMessage {\n"
        "  print STDERR <<ENDOFHELP;\n"
        "Interactive pprof mode\n"
        "Commands:\n"
        "  gv\n"
        "  gv [focus] [-ignore1] [-ignore2]\n"
        "      Show graphical hierarchical display of current profile.  Without\n"
        "      any arguments, shows all samples in the profile.  With the optional\n"
        "      \"focus\" argument, restricts the samples shown to just those where\n"
        "      the \"focus\" regular expression matches a routine name on the stack\n"
        "      trace.\n"
        "  web\n"
        "  web [focus] [-ignore1] [-ignore2]\n"
        "      Like GV, but displays profile in your web browser instead of using\n"
        "      Ghostview. Works best if your web browser is already running.\n"
        "      To change the browser that gets used:\n"
        "      On Linux, set the /etc/alternatives/gnome-www-browser symlink.\n"
        "      On OS X, change the Finder association for SVG files.\n"
        "  list [routine_regexp] [-ignore1] [-ignore2]\n"
        "      Show source listing of routines whose names match \"routine_regexp\"\n"
        "  weblist [routine_regexp] [-ignore1] [-ignore2]\n"
        "     Displays a source listing of routines whose names match \"routine_regexp\"\n"
        "     in a web browser.  You can click on source lines to view the\n"
        "     corresponding disassembly.\n"
        "  top [--cum] [-ignore1] [-ignore2]\n"
        "  top20 [--cum] [-ignore1] [-ignore2]\n"
        "  top37 [--cum] [-ignore1] [-ignore2]\n"
        "      Show top lines ordered by flat profile count, or cumulative count\n"
        "      if --cum is specified.  If a number is present after 'top', the\n"
        "      top K routines will be shown (defaults to showing the top 10)\n"
        "  disasm [routine_regexp] [-ignore1] [-ignore2]\n"
        "      Show disassembly of routines whose names match \"routine_regexp\",\n"
        "      annotated with sample counts.\n"
        "  callgrind\n"
        "  callgrind [filename]\n"
        "      Generates callgrind file. If no filename is given, kcachegrind is called.\n"
        "  help - This listing\n"
        "  quit or ^D - End pprof\n"
        "For commands that accept optional -ignore tags, samples where any routine in\n"
        "the stack trace matches the regular expression in any of the -ignore\n"
        "parameters will be ignored.\n"
        "Further pprof details are available at this location (or one similar):\n"
        " /usr/doc/gperftools-$PPROF_VERSION/cpu_profiler.html\n"
        " /usr/doc/gperftools-$PPROF_VERSION/heap_profiler.html\n"
        "ENDOFHELP\n"
        "}\n"
        "sub ParseInteractiveArgs {\n"
        "  my $args = shift;\n"
        "  my $focus = \"\";\n"
        "  my $ignore = \"\";\n"
        "  my @x = split(/ +/, $args);\n"
        "  foreach $a (@x) {\n"
        "    if ($a =~ m/^(--|-)lines$/) {\n"
        "      $main::opt_lines = 1;\n"
        "    } elsif ($a =~ m/^(--|-)cum$/) {\n"
        "      $main::opt_cum = 1;\n"
        "    } elsif ($a =~ m/^-(.*)/) {\n"
        "      $ignore .= (($ignore ne \"\") ? \"|\" : \"\" ) . $1;\n"
        "    } else {\n"
        "      $focus .= (($focus ne \"\") ? \"|\" : \"\" ) . $a;\n"
        "    }\n"
        "  }\n"
        "  if ($ignore ne \"\") {\n"
        "    print STDERR \"Ignoring samples in call stacks that match '$ignore'\\n\";\n"
        "  }\n"
        "  return ($focus, $ignore);\n"
        "}\n"
        "\n"
        "##### Output code #####\n"
        "\n"
        "sub TempName {\n"
        "  my $fnum = shift;\n"
        "  my $ext = shift;\n"
        "  my $file = \"$main::tmpfile_ps.$fnum.$ext\";\n"
        "  $main::tempnames{$file} = 1;\n"
        "  return $file;\n"
        "}\n"
        "\n"
        "# Print profile data in packed binary format (64-bit) to standard out\n"
        "sub PrintProfileData {\n"
        "  my $profile = shift;\n"
        "  my $big_endian = pack(\"L\", 1) eq pack(\"N\", 1);\n"
        "  # print header (64-bit style)\n"
        "  # (zero) (header-size) (version) (sample-period) (zero)\n"
        "  if ($big_endian) {\n"
        "    print pack('L*', 0, 0, 0, 3, 0, 0, 0, 1, 0, 0);\n"
        "  }\n"
        "  else {\n"
        "    print pack('L*', 0, 0, 3, 0, 0, 0, 1, 0, 0, 0);\n"
        "  }\n"
        "\n"
        "  foreach my $k (keys(%{$profile})) {\n"
        "    my $count = $profile->{$k};\n"
        "    my @addrs = split(/\\n/, $k);\n"
        "    if ($#addrs >= 0) {\n"
        "      my $depth = $#addrs + 1;\n"
        "      # int(foo / 2**32) is the only reliable way to get rid of bottom\n"
        "      # 32 bits on both 32- and 64-bit systems.\n"
        "      if ($big_endian) {\n"
        "        print pack('L*', int($count / 2**32), $count & 0xFFFFFFFF);\n"
        "        print pack('L*', int($depth / 2**32), $depth & 0xFFFFFFFF);\n"
        "      }\n"
        "      else {\n"
        "        print pack('L*', $count & 0xFFFFFFFF, int($count / 2**32));\n"
        "        print pack('L*', $depth & 0xFFFFFFFF, int($depth / 2**32));\n"
        "      }\n"
        "\n"
        "      foreach my $full_addr (@addrs) {\n"
        "        my $addr = $full_addr;\n"
        "        $addr =~ s/0x0*//;  # strip off leading 0x, zeroes\n"
        "        if (length($addr) > 16) {\n"
        "          print STDERR \"Invalid address in profile: $full_addr\\n\";\n"
        "          next;\n"
        "        }\n"
        "        my $low_addr = substr($addr, -8);       # get last 8 hex chars\n"
        "        my $high_addr = substr($addr, -16, 8);  # get up to 8 more hex chars\n"
        "        if ($big_endian) {\n"
        "          print pack('L*', hex('0x' . $high_addr), hex('0x' . $low_addr));\n"
        "        }\n"
        "        else {\n"
        "          print pack('L*', hex('0x' . $low_addr), hex('0x' . $high_addr));\n"
        "        }\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "}\n"
        "\n"
        "# Print symbols and profile data\n"
        "sub PrintSymbolizedProfile {\n"
        "  my $symbols = shift;\n"
        "  my $profile = shift;\n"
        "  my $prog = shift;\n"
        "\n"
        "  $SYMBOL_PAGE =~ m,[^/]+$,;    # matches everything after the last slash\n"
        "  my $symbol_marker = $&;\n"
        "\n"
        "  print '--- ', $symbol_marker, \"\\n\";\n"
        "  if (defined($prog)) {\n"
        "    print 'binary=', $prog, \"\\n\";\n"
        "  }\n"
        "  while (my ($pc, $name) = each(%{$symbols})) {\n"
        "    my $sep = ' ';\n"
        "    print '0x', $pc;\n"
        "    # We have a list of function names, which include the inlined\n"
        "    # calls.  They are separated (and terminated) by --, which is\n"
        "    # illegal in function names.\n"
        "    for (my $j = 2; $j <= $#{$name}; $j += 3) {\n"
        "      print $sep, $name->[$j];\n"
        "      $sep = '--';\n"
        "    }\n"
        "    print \"\\n\";\n"
        "  }\n"
        "  print '---', \"\\n\";\n"
        "\n"
        "  $PROFILE_PAGE =~ m,[^/]+$,;    # matches everything after the last slash\n"
        "  my $profile_marker = $&;\n"
        "  print '--- ', $profile_marker, \"\\n\";\n"
        "  if (defined($main::collected_profile)) {\n"
        "    # if used with remote fetch, simply dump the collected profile to output.\n"
        "    open(SRC, \"<$main::collected_profile\");\n"
        "    while (<SRC>) {\n"
        "      print $_;\n"
        "    }\n"
        "    close(SRC);\n"
        "  } else {\n"
        "    # dump a cpu-format profile to standard out\n"
        "    PrintProfileData($profile);\n"
        "  }\n"
        "}\n"
        "\n"
        "# Print text output\n"
        "sub PrintText {\n"
        "  my $symbols = shift;\n"
        "  my $flat = shift;\n"
        "  my $cumulative = shift;\n"
        "  my $line_limit = shift;\n"
        "\n"
        "  if ($main::opt_stacks && @stackTraces) {\n"
        "      foreach (sort { (split \" \", $b)[1] <=> (split \" \", $a)[1]; } @stackTraces) "
        "{\n"
        "	  print \"$_\\n\" if $main::opt_debug;\n"
        "	  my ($n1, $s1, $n2, $s2, @addrs) = split;\n"
        "	  print \"Leak of $s1 bytes in $n1 objects allocated from:\\n\";\n"
        "	  foreach my $pcstr (@addrs) {\n"
        "	      $pcstr =~ s/^0x//;\n"
        "	      my $sym;\n"
        "	      if (! defined $symbols->{$pcstr}) {\n"
        "		  $sym = \"unknown\";\n"
        "	      } else {\n"
        "		  $sym = \"$symbols->{$pcstr}[0] $symbols->{$pcstr}[1]\";\n"
        "	      }\n"
        "	      print \"\\t@ $pcstr $sym\\n\";\n"
        "	  }\n"
        "      }\n"
        "      print \"\\n\";\n"
        "  }\n"
        "\n"
        "  my $total = TotalProfile($flat);\n"
        "\n"
        "  # Which profile to sort by?\n"
        "  my $s = $main::opt_cum ? $cumulative : $flat;\n"
        "\n"
        "  my $running_sum = 0;\n"
        "  my $lines = 0;\n"
        "  foreach my $k (sort { GetEntry($s, $b) <=> GetEntry($s, $a) || $a cmp $b }\n"
        "                 keys(%{$cumulative})) {\n"
        "    my $f = GetEntry($flat, $k);\n"
        "    my $c = GetEntry($cumulative, $k);\n"
        "    $running_sum += $f;\n"
        "\n"
        "    my $sym = $k;\n"
        "    if (exists($symbols->{$k})) {\n"
        "      $sym = $symbols->{$k}->[0] . \" \" . $symbols->{$k}->[1];\n"
        "      if ($main::opt_addresses) {\n"
        "        $sym = $k . \" \" . $sym;\n"
        "      }\n"
        "    }\n"
        "\n"
        "    if ($f != 0 || $c != 0) {\n"
        "      printf(\"%8s %6s %6s %8s %6s %s\\n\",\n"
        "             Unparse($f),\n"
        "             Percent($f, $total),\n"
        "             Percent($running_sum, $total),\n"
        "             Unparse($c),\n"
        "             Percent($c, $total),\n"
        "             $sym);\n"
        "    }\n"
        "    $lines++;\n"
        "    last if ($line_limit >= 0 && $lines >= $line_limit);\n"
        "  }\n"
        "}\n"
        "\n"
        "# Callgrind format has a compression for repeated function and file\n"
        "# names.  You show the name the first time, and just use its number\n"
        "# subsequently.  This can cut down the file to about a third or a\n"
        "# quarter of its uncompressed size.  $key and $val are the key/value\n"
        "# pair that would normally be printed by callgrind; $map is a map from\n"
        "# value to number.\n"
        "sub CompressedCGName {\n"
        "  my($key, $val, $map) = @_;\n"
        "  my $idx = $map->{$val};\n"
        "  # For very short keys, providing an index hurts rather than helps.\n"
        "  if (length($val) <= 3) {\n"
        "    return \"$key=$val\\n\";\n"
        "  } elsif (defined($idx)) {\n"
        "    return \"$key=($idx)\\n\";\n"
        "  } else {\n"
        "    # scalar(keys $map) gives the number of items in the map.\n"
        "    $idx = scalar(keys(%{$map})) + 1;\n"
        "    $map->{$val} = $idx;\n"
        "    return \"$key=($idx) $val\\n\";\n"
        "  }\n"
        "}\n"
        "\n"
        "# Print the call graph in a way that's suiteable for callgrind.\n"
        "sub PrintCallgrind {\n"
        "  my $calls = shift;\n"
        "  my $filename;\n"
        "  my %filename_to_index_map;\n"
        "  my %fnname_to_index_map;\n"
        "\n"
        "  if ($main::opt_interactive) {\n"
        "    $filename = shift;\n"
        "    print STDERR \"Writing callgrind file to '$filename'.\\n\"\n"
        "  } else {\n"
        "    $filename = \"&STDOUT\";\n"
        "  }\n"
        "  open(CG, \">$filename\");\n"
        "  print CG (\"events: Hits\\n\\n\");\n"
        "  foreach my $call ( map { $_->[0] }\n"
        "                     sort { $a->[1] cmp $b ->[1] ||\n"
        "                            $a->[2] <=> $b->[2] }\n"
        "                     map { /([^:]+):(\\d+):([^ ]+)( -> ([^:]+):(\\d+):(.+))?/;\n"
        "                           [$_, $1, $2] }\n"
        "                     keys %$calls ) {\n"
        "    my $count = int($calls->{$call});\n"
        "    $call =~ /([^:]+):(\\d+):([^ ]+)( -> ([^:]+):(\\d+):(.+))?/;\n"
        "    my ( $caller_file, $caller_line, $caller_function,\n"
        "         $callee_file, $callee_line, $callee_function ) =\n"
        "       ( $1, $2, $3, $5, $6, $7 );\n"
        "\n"
        "    # TODO(csilvers): for better compression, collect all the\n"
        "    # caller/callee_files and functions first, before printing\n"
        "    # anything, and only compress those referenced more than once.\n"
        "    print CG CompressedCGName(\"fl\", $caller_file, \\%filename_to_index_map);\n"
        "    print CG CompressedCGName(\"fn\", $caller_function, \\%fnname_to_index_map);\n"
        "    if (defined $6) {\n"
        "      print CG CompressedCGName(\"cfl\", $callee_file, \\%filename_to_index_map);\n"
        "      print CG CompressedCGName(\"cfn\", $callee_function, \\%fnname_to_index_map);\n"
        "      print CG (\"calls=$count $callee_line\\n\");\n"
        "    }\n"
        "    print CG (\"$caller_line $count\\n\\n\");\n"
        "  }\n"
        "}\n"
        "\n"
        "# Print disassembly for all all routines that match $main::opt_disasm\n"
        "sub PrintDisassembly {\n"
        "  my $libs = shift;\n"
        "  my $flat = shift;\n"
        "  my $cumulative = shift;\n"
        "  my $disasm_opts = shift;\n"
        "\n"
        "  my $total = TotalProfile($flat);\n"
        "\n"
        "  foreach my $lib (@{$libs}) {\n"
        "    my $symbol_table = GetProcedureBoundaries($lib->[0], $disasm_opts);\n"
        "    my $offset = AddressSub($lib->[1], $lib->[3]);\n"
        "    foreach my $routine (sort ByName keys(%{$symbol_table})) {\n"
        "      my $start_addr = $symbol_table->{$routine}->[0];\n"
        "      my $end_addr = $symbol_table->{$routine}->[1];\n"
        "      # See if there are any samples in this routine\n"
        "      my $length = hex(AddressSub($end_addr, $start_addr));\n"
        "      my $addr = AddressAdd($start_addr, $offset);\n"
        "      for (my $i = 0; $i < $length; $i++) {\n"
        "        if (defined($cumulative->{$addr})) {\n"
        "          PrintDisassembledFunction($lib->[0], $offset,\n"
        "                                    $routine, $flat, $cumulative,\n"
        "                                    $start_addr, $end_addr, $total);\n"
        "          last;\n"
        "        }\n"
        "        $addr = AddressInc($addr);\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "}\n"
        "\n"
        "# Return reference to array of tuples of the form:\n"
        "#       [start_address, filename, linenumber, instruction, limit_address]\n"
        "# E.g.,\n"
        "#       [\"0x806c43d\", \"/foo/bar.cc\", 131, \"ret\", \"0x806c440\"]\n"
        "sub Disassemble {\n"
        "  my $prog = shift;\n"
        "  my $offset = shift;\n"
        "  my $start_addr = shift;\n"
        "  my $end_addr = shift;\n"
        "\n"
        "  my $objdump = $obj_tool_map{\"objdump\"};\n"
        "  my $cmd = ShellEscape($objdump, \"-C\", \"-d\", \"-l\", \"--no-show-raw-insn\",\n"
        "                        \"--start-address=0x$start_addr\",\n"
        "                        \"--stop-address=0x$end_addr\", $prog);\n"
        "  open(OBJDUMP, \"$cmd |\") || error(\"$cmd: $!\\n\");\n"
        "  my @result = ();\n"
        "  my $filename = \"\";\n"
        "  my $linenumber = -1;\n"
        "  my $last = [\"\", \"\", \"\", \"\"];\n"
        "  while (<OBJDUMP>) {\n"
        "    s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "    chop;\n"
        "    if (m|\\s*([^:\\s]+):(\\d+)\\s*$|) {\n"
        "      # Location line of the form:\n"
        "      #   <filename>:<linenumber>\n"
        "      $filename = $1;\n"
        "      $linenumber = $2;\n"
        "    } elsif (m/^ +([0-9a-f]+):\\s*(.*)/) {\n"
        "      # Disassembly line -- zero-extend address to full length\n"
        "      my $addr = HexExtend($1);\n"
        "      my $k = AddressAdd($addr, $offset);\n"
        "      $last->[4] = $k;   # Store ending address for previous instruction\n"
        "      $last = [$k, $filename, $linenumber, $2, $end_addr];\n"
        "      push(@result, $last);\n"
        "    }\n"
        "  }\n"
        "  close(OBJDUMP);\n"
        "  return @result;\n"
        "}\n"
        "\n"
        "# The input file should contain lines of the form /proc/maps-like\n"
        "# output (same format as expected from the profiles) or that looks\n"
        "# like hex addresses (like \"0xDEADBEEF\").  We will parse all\n"
        "# /proc/maps output, and for all the hex addresses, we will output\n"
        "# \"short\" symbol names, one per line, in the same order as the input.\n"
        "sub PrintSymbols {\n"
        "  my $maps_and_symbols_file = shift;\n"
        "\n"
        "  # ParseLibraries expects pcs to be in a set.  Fine by us...\n"
        "  my @pclist = ();   # pcs in sorted order\n"
        "  my $pcs = {};\n"
        "  my $map = \"\";\n"
        "  foreach my $line (<$maps_and_symbols_file>) {\n"
        "    $line =~ s/\\r//g;    # turn windows-looking lines into unix-looking lines\n"
        "    if ($line =~ /\\b(0x[0-9a-f]+)\\b/i) {\n"
        "      push(@pclist, HexExtend($1));\n"
        "      $pcs->{$pclist[-1]} = 1;\n"
        "    } else {\n"
        "      $map .= $line;\n"
        "    }\n"
        "  }\n"
        "\n"
        "  my $libs = ParseLibraries($main::prog, $map, $pcs);\n"
        "  my $symbols = ExtractSymbols($libs, $pcs);\n"
        "\n"
        "  foreach my $pc (@pclist) {\n"
        "    # ->[0] is the shortname, ->[2] is the full name\n"
        "    print(($symbols->{$pc}->[0] || \"\?\?\") . \"\\n\");\n"
        "  }\n"
        "}\n"
        "\n"
        "\n"
        "# For sorting functions by name\n"
        "sub ByName {\n"
        "  return ShortFunctionName($a) cmp ShortFunctionName($b);\n"
        "}\n"
        "\n"
        "# Print source-listing for all all routines that match $list_opts\n"
        "sub PrintListing {\n"
        "  my $total = shift;\n"
        "  my $libs = shift;\n"
        "  my $flat = shift;\n"
        "  my $cumulative = shift;\n"
        "  my $list_opts = shift;\n"
        "  my $html = shift;\n"
        "\n"
        "  my $output = \\*STDOUT;\n"
        "  my $fname = \"\";\n"
        "\n"
        "  if ($html) {\n"
        "    # Arrange to write the output to a temporary file\n"
        "    $fname = TempName($main::next_tmpfile, \"html\");\n"
        "    $main::next_tmpfile++;\n"
        "    if (!open(TEMP, \">$fname\")) {\n"
        "      print STDERR \"$fname: $!\\n\";\n"
        "      return;\n"
        "    }\n"
        "    $output = \\*TEMP;\n"
        "    print $output HtmlListingHeader();\n"
        "    printf $output (\"<div class=\\\"legend\\\">%s<br>Total: %s %s</div>\\n\",\n"
        "                    $main::prog, Unparse($total), Units());\n"
        "  }\n"
        "\n"
        "  my $listed = 0;\n"
        "  foreach my $lib (@{$libs}) {\n"
        "    my $symbol_table = GetProcedureBoundaries($lib->[0], $list_opts);\n"
        "    my $offset = AddressSub($lib->[1], $lib->[3]);\n"
        "    foreach my $routine (sort ByName keys(%{$symbol_table})) {\n"
        "      # Print if there are any samples in this routine\n"
        "      my $start_addr = $symbol_table->{$routine}->[0];\n"
        "      my $end_addr = $symbol_table->{$routine}->[1];\n"
        "      my $length = hex(AddressSub($end_addr, $start_addr));\n"
        "      my $addr = AddressAdd($start_addr, $offset);\n"
        "      for (my $i = 0; $i < $length; $i++) {\n"
        "        if (defined($cumulative->{$addr})) {\n"
        "          $listed += PrintSource(\n"
        "            $lib->[0], $offset,\n"
        "            $routine, $flat, $cumulative,\n"
        "            $start_addr, $end_addr,\n"
        "            $html,\n"
        "            $output);\n"
        "          last;\n"
        "        }\n"
        "        $addr = AddressInc($addr);\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "\n"
        "  if ($html) {\n"
        "    if ($listed > 0) {\n"
        "      print $output HtmlListingFooter();\n"
        "      close($output);\n"
        "      RunWeb($fname);\n"
        "    } else {\n"
        "      close($output);\n"
        "      unlink($fname);\n"
        "    }\n"
        "  }\n"
        "}\n"
        "\n"
        "sub HtmlListingHeader {\n"
        "  return <<'EOF';\n"
        "<DOCTYPE html>\n"
        "<html>\n"
        "<head>\n"
        "<title>Pprof listing</title>\n"
        "<style type=\"text/css\">\n"
        "body {\n"
        "  font-family: sans-serif;\n"
        "}\n"
        "h1 {\n"
        "  font-size: 1.5em;\n"
        "  margin-bottom: 4px;\n"
        "}\n"
        ".legend {\n"
        "  font-size: 1.25em;\n"
        "}\n"
        ".line {\n"
        "  color: #aaaaaa;\n"
        "}\n"
        ".nop {\n"
        "  color: #aaaaaa;\n"
        "}\n"
        ".unimportant {\n"
        "  color: #cccccc;\n"
        "}\n"
        ".disasmloc {\n"
        "  color: #000000;\n"
        "}\n"
        ".deadsrc {\n"
        "  cursor: pointer;\n"
        "}\n"
        ".deadsrc:hover {\n"
        "  background-color: #eeeeee;\n"
        "}\n"
        ".livesrc {\n"
        "  color: #0000ff;\n"
        "  cursor: pointer;\n"
        "}\n"
        ".livesrc:hover {\n"
        "  background-color: #eeeeee;\n"
        "}\n"
        ".asm {\n"
        "  color: #008800;\n"
        "  display: none;\n"
        "}\n"
        "</style>\n"
        "<script type=\"text/javascript\">\n"
        "function pprof_toggle_asm(e) {\n"
        "  var target;\n"
        "  if (!e) e = window.event;\n"
        "  if (e.target) target = e.target;\n"
        "  else if (e.srcElement) target = e.srcElement;\n"
        "  if (target) {\n"
        "    var asm = target.nextSibling;\n"
        "    if (asm && asm.className == \"asm\") {\n"
        "      asm.style.display = (asm.style.display == \"block\" ? \"\" : \"block\");\n"
        "      e.preventDefault();\n"
        "      return false;\n"
        "    }\n"
        "  }\n"
        "}\n"
        "</script>\n"
        "</head>\n"
        "<body>\n"
        "EOF\n"
        "}\n"
        "\n"
        "sub HtmlListingFooter {\n"
        "  return <<'EOF';\n"
        "</body>\n"
        "</html>\n"
        "EOF\n"
        "}\n"
        "\n"
        "sub HtmlEscape {\n"
        "  my $text = shift;\n"
        "  $text =~ s/&/&amp;/g;\n"
        "  $text =~ s/</&lt;/g;\n"
        "  $text =~ s/>/&gt;/g;\n"
        "  return $text;\n"
        "}\n"
        "\n"
        "# Returns the indentation of the line, if it has any non-whitespace\n"
        "# characters.  Otherwise, returns -1.\n"
        "sub Indentation {\n"
        "  my $line = shift;\n"
        "  if (m/^(\\s*)\\S/) {\n"
        "    return length($1);\n"
        "  } else {\n"
        "    return -1;\n"
        "  }\n"
        "}\n"
        "\n"
        "# If the symbol table contains inlining info, Disassemble() may tag an\n"
        "# instruction with a location inside an inlined function.  But for\n"
        "# source listings, we prefer to use the location in the function we\n"
        "# are listing.  So use MapToSymbols() to fetch full location\n"
        "# information for each instruction and then pick out the first\n"
        "# location from a location list (location list contains callers before\n"
        "# callees in case of inlining).\n"
        "#\n"
        "# After this routine has run, each entry in $instructions contains:\n"
        "#   [0] start address\n"
        "#   [1] filename for function we are listing\n"
        "#   [2] line number for function we are listing\n"
        "#   [3] disassembly\n"
        "#   [4] limit address\n"
        "#   [5] most specific filename (may be different from [1] due to inlining)\n"
        "#   [6] most specific line number (may be different from [2] due to inlining)\n"
        "sub GetTopLevelLineNumbers {\n"
        "  my ($lib, $offset, $instructions) = @_;\n"
        "  my $pcs = [];\n"
        "  for (my $i = 0; $i <= $#{$instructions}; $i++) {\n"
        "    push(@{$pcs}, $instructions->[$i]->[0]);\n"
        "  }\n"
        "  my $symbols = {};\n"
        "  MapToSymbols($lib, $offset, $pcs, $symbols);\n"
        "  for (my $i = 0; $i <= $#{$instructions}; $i++) {\n"
        "    my $e = $instructions->[$i];\n"
        "    push(@{$e}, $e->[1]);\n"
        "    push(@{$e}, $e->[2]);\n"
        "    my $addr = $e->[0];\n"
        "    my $sym = $symbols->{$addr};\n"
        "    if (defined($sym)) {\n"
        "      if ($#{$sym} >= 2 && $sym->[1] =~ m/^(.*):(\\d+)$/) {\n"
        "        $e->[1] = $1;  # File name\n"
        "        $e->[2] = $2;  # Line number\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "}\n"
        "\n"
        "# Print source-listing for one routine\n"
        "sub PrintSource {\n"
        "  my $prog = shift;\n"
        "  my $offset = shift;\n"
        "  my $routine = shift;\n"
        "  my $flat = shift;\n"
        "  my $cumulative = shift;\n"
        "  my $start_addr = shift;\n"
        "  my $end_addr = shift;\n"
        "  my $html = shift;\n"
        "  my $output = shift;\n"
        "\n"
        "  # Disassemble all instructions (just to get line numbers)\n"
        "  my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);\n"
        "  GetTopLevelLineNumbers($prog, $offset, \\@instructions);\n"
        "\n"
        "  # Hack 1: assume that the first source file encountered in the\n"
        "  # disassembly contains the routine\n"
        "  my $filename = undef;\n"
        "  for (my $i = 0; $i <= $#instructions; $i++) {\n"
        "    if ($instructions[$i]->[2] >= 0) {\n"
        "      $filename = $instructions[$i]->[1];\n"
        "      last;\n"
        "    }\n"
        "  }\n"
        "  if (!defined($filename)) {\n"
        "    print STDERR \"no filename found in $routine\\n\";\n"
        "    return 0;\n"
        "  }\n"
        "\n"
        "  # Hack 2: assume that the largest line number from $filename is the\n"
        "  # end of the procedure.  This is typically safe since if P1 contains\n"
        "  # an inlined call to P2, then P2 usually occurs earlier in the\n"
        "  # source file.  If this does not work, we might have to compute a\n"
        "  # density profile or just print all regions we find.\n"
        "  my $lastline = 0;\n"
        "  for (my $i = 0; $i <= $#instructions; $i++) {\n"
        "    my $f = $instructions[$i]->[1];\n"
        "    my $l = $instructions[$i]->[2];\n"
        "    if (($f eq $filename) && ($l > $lastline)) {\n"
        "      $lastline = $l;\n"
        "    }\n"
        "  }\n"
        "\n"
        "  # Hack 3: assume the first source location from \"filename\" is the start of\n"
        "  # the source code.\n"
        "  my $firstline = 1;\n"
        "  for (my $i = 0; $i <= $#instructions; $i++) {\n"
        "    if ($instructions[$i]->[1] eq $filename) {\n"
        "      $firstline = $instructions[$i]->[2];\n"
        "      last;\n"
        "    }\n"
        "  }\n"
        "\n"
        "  # Hack 4: Extend last line forward until its indentation is less than\n"
        "  # the indentation we saw on $firstline\n"
        "  my $oldlastline = $lastline;\n"
        "  {\n"
        "    if (!open(FILE, \"<$filename\")) {\n"
        "      print STDERR \"$filename: $!\\n\";\n"
        "      return 0;\n"
        "    }\n"
        "    my $l = 0;\n"
        "    my $first_indentation = -1;\n"
        "    while (<FILE>) {\n"
        "      s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "      $l++;\n"
        "      my $indent = Indentation($_);\n"
        "      if ($l >= $firstline) {\n"
        "        if ($first_indentation < 0 && $indent >= 0) {\n"
        "          $first_indentation = $indent;\n"
        "          last if ($first_indentation == 0);\n"
        "        }\n"
        "      }\n"
        "      if ($l >= $lastline && $indent >= 0) {\n"
        "        if ($indent >= $first_indentation) {\n"
        "          $lastline = $l+1;\n"
        "        } else {\n"
        "          last;\n"
        "        }\n"
        "      }\n"
        "    }\n"
        "    close(FILE);\n"
        "  }\n"
        "\n"
        "  # Assign all samples to the range $firstline,$lastline,\n"
        "  # Hack 4: If an instruction does not occur in the range, its samples\n"
        "  # are moved to the next instruction that occurs in the range.\n"
        "  my $samples1 = {};        # Map from line number to flat count\n"
        "  my $samples2 = {};        # Map from line number to cumulative count\n"
        "  my $running1 = 0;         # Unassigned flat counts\n"
        "  my $running2 = 0;         # Unassigned cumulative counts\n"
        "  my $total1 = 0;           # Total flat counts\n"
        "  my $total2 = 0;           # Total cumulative counts\n"
        "  my %disasm = ();          # Map from line number to disassembly\n"
        "  my $running_disasm = \"\";  # Unassigned disassembly\n"
        "  my $skip_marker = \"---\\n\";\n"
        "  if ($html) {\n"
        "    $skip_marker = \"\";\n"
        "    for (my $l = $firstline; $l <= $lastline; $l++) {\n"
        "      $disasm{$l} = \"\";\n"
        "    }\n"
        "  }\n"
        "  my $last_dis_filename = '';\n"
        "  my $last_dis_linenum = -1;\n"
        "  my $last_touched_line = -1;  # To detect gaps in disassembly for a line\n"
        "  foreach my $e (@instructions) {\n"
        "    # Add up counts for all address that fall inside this instruction\n"
        "    my $c1 = 0;\n"
        "    my $c2 = 0;\n"
        "    for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {\n"
        "      $c1 += GetEntry($flat, $a);\n"
        "      $c2 += GetEntry($cumulative, $a);\n"
        "    }\n"
        "\n"
        "    if ($html) {\n"
        "      my $dis = sprintf(\"      %6s %6s \\t\\t%8s: %s \",\n"
        "                        HtmlPrintNumber($c1),\n"
        "                        HtmlPrintNumber($c2),\n"
        "                        UnparseAddress($offset, $e->[0]),\n"
        "                        CleanDisassembly($e->[3]));\n"
        "      \n"
        "      # Append the most specific source line associated with this instruction\n"
        "      if (length($dis) < 80) { $dis .= (' ' x (80 - length($dis))) };\n"
        "      $dis = HtmlEscape($dis);\n"
        "      my $f = $e->[5];\n"
        "      my $l = $e->[6];\n"
        "      if ($f ne $last_dis_filename) {\n"
        "        $dis .= sprintf(\"<span class=disasmloc>%s:%d</span>\", \n"
        "                        HtmlEscape(CleanFileName($f)), $l);\n"
        "      } elsif ($l ne $last_dis_linenum) {\n"
        "        # De-emphasize the unchanged file name portion\n"
        "        $dis .= sprintf(\"<span class=unimportant>%s</span>\" .\n"
        "                        \"<span class=disasmloc>:%d</span>\", \n"
        "                        HtmlEscape(CleanFileName($f)), $l);\n"
        "      } else {\n"
        "        # De-emphasize the entire location\n"
        "        $dis .= sprintf(\"<span class=unimportant>%s:%d</span>\", \n"
        "                        HtmlEscape(CleanFileName($f)), $l);\n"
        "      }\n"
        "      $last_dis_filename = $f;\n"
        "      $last_dis_linenum = $l;\n"
        "      $running_disasm .= $dis;\n"
        "      $running_disasm .= \"\\n\";\n"
        "    }\n"
        "\n"
        "    $running1 += $c1;\n"
        "    $running2 += $c2;\n"
        "    $total1 += $c1;\n"
        "    $total2 += $c2;\n"
        "    my $file = $e->[1];\n"
        "    my $line = $e->[2];\n"
        "    if (($file eq $filename) &&\n"
        "        ($line >= $firstline) &&\n"
        "        ($line <= $lastline)) {\n"
        "      # Assign all accumulated samples to this line\n"
        "      AddEntry($samples1, $line, $running1);\n"
        "      AddEntry($samples2, $line, $running2);\n"
        "      $running1 = 0;\n"
        "      $running2 = 0;\n"
        "      if ($html) {\n"
        "        if ($line != $last_touched_line && $disasm{$line} ne '') {\n"
        "          $disasm{$line} .= \"\\n\";\n"
        "        }\n"
        "        $disasm{$line} .= $running_disasm;\n"
        "        $running_disasm = '';\n"
        "        $last_touched_line = $line;\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "\n"
        "  # Assign any leftover samples to $lastline\n"
        "  AddEntry($samples1, $lastline, $running1);\n"
        "  AddEntry($samples2, $lastline, $running2);\n"
        "  if ($html) {\n"
        "    if ($lastline != $last_touched_line && $disasm{$lastline} ne '') {\n"
        "      $disasm{$lastline} .= \"\\n\";\n"
        "    }\n"
        "    $disasm{$lastline} .= $running_disasm;\n"
        "  }\n"
        "\n"
        "  if ($html) {\n"
        "    printf $output (\n"
        "      \"<h1>%s</h1>%s\\n<pre onClick=\\\"pprof_toggle_asm()\\\">\\n\" .\n"
        "      \"Total:%6s %6s (flat / cumulative %s)\\n\",\n"
        "      HtmlEscape(ShortFunctionName($routine)),\n"
        "      HtmlEscape(CleanFileName($filename)),\n"
        "      Unparse($total1),\n"
        "      Unparse($total2),\n"
        "      Units());\n"
        "  } else {\n"
        "    printf $output (\n"
        "      \"ROUTINE ====================== %s in %s\\n\" .\n"
        "      \"%6s %6s Total %s (flat / cumulative)\\n\",\n"
        "      ShortFunctionName($routine),\n"
        "      CleanFileName($filename),\n"
        "      Unparse($total1),\n"
        "      Unparse($total2),\n"
        "      Units());\n"
        "  }\n"
        "  if (!open(FILE, \"<$filename\")) {\n"
        "    print STDERR \"$filename: $!\\n\";\n"
        "    return 0;\n"
        "  }\n"
        "  my $l = 0;\n"
        "  while (<FILE>) {\n"
        "    s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "    $l++;\n"
        "    if ($l >= $firstline - 5 &&\n"
        "        (($l <= $oldlastline + 5) || ($l <= $lastline))) {\n"
        "      chop;\n"
        "      my $text = $_;\n"
        "      if ($l == $firstline) { print $output $skip_marker; }\n"
        "      my $n1 = GetEntry($samples1, $l);\n"
        "      my $n2 = GetEntry($samples2, $l);\n"
        "      if ($html) {\n"
        "        # Emit a span that has one of the following classes:\n"
        "        #    livesrc -- has samples\n"
        "        #    deadsrc -- has disassembly, but with no samples\n"
        "        #    nop     -- has no matching disasembly\n"
        "        # Also emit an optional span containing disassembly.\n"
        "        my $dis = $disasm{$l};\n"
        "        my $asm = \"\";\n"
        "        if (defined($dis) && $dis ne '') {\n"
        "          $asm = \"<span class=\\\"asm\\\">\" . $dis . \"</span>\";\n"
        "        }\n"
        "        my $source_class = (($n1 + $n2 > 0) \n"
        "                            ? \"livesrc\" \n"
        "                            : (($asm ne \"\") ? \"deadsrc\" : \"nop\"));\n"
        "        printf $output (\n"
        "          \"<span class=\\\"line\\\">%5d</span> \" .\n"
        "          \"<span class=\\\"%s\\\">%6s %6s %s</span>%s\\n\",\n"
        "          $l, $source_class,\n"
        "          HtmlPrintNumber($n1),\n"
        "          HtmlPrintNumber($n2),\n"
        "          HtmlEscape($text),\n"
        "          $asm);\n"
        "      } else {\n"
        "        printf $output(\n"
        "          \"%6s %6s %4d: %s\\n\",\n"
        "          UnparseAlt($n1),\n"
        "          UnparseAlt($n2),\n"
        "          $l,\n"
        "          $text);\n"
        "      }\n"
        "      if ($l == $lastline)  { print $output $skip_marker; }\n"
        "    };\n"
        "  }\n"
        "  close(FILE);\n"
        "  if ($html) {\n"
        "    print $output \"</pre>\\n\";\n"
        "  }\n"
        "  return 1;\n"
        "}\n"
        "\n"
        "# Return the source line for the specified file/linenumber.\n"
        "# Returns undef if not found.\n"
        "sub SourceLine {\n"
        "  my $file = shift;\n"
        "  my $line = shift;\n"
        "\n"
        "  # Look in cache\n"
        "  if (!defined($main::source_cache{$file})) {\n"
        "    if (100 < scalar keys(%main::source_cache)) {\n"
        "      # Clear the cache when it gets too big\n"
        "      $main::source_cache = ();\n"
        "    }\n"
        "\n"
        "    # Read all lines from the file\n"
        "    if (!open(FILE, \"<$file\")) {\n"
        "      print STDERR \"$file: $!\\n\";\n"
        "      $main::source_cache{$file} = [];  # Cache the negative result\n"
        "      return undef;\n"
        "    }\n"
        "    my $lines = [];\n"
        "    push(@{$lines}, \"\");        # So we can use 1-based line numbers as indices\n"
        "    while (<FILE>) {\n"
        "      push(@{$lines}, $_);\n"
        "    }\n"
        "    close(FILE);\n"
        "\n"
        "    # Save the lines in the cache\n"
        "    $main::source_cache{$file} = $lines;\n"
        "  }\n"
        "\n"
        "  my $lines = $main::source_cache{$file};\n"
        "  if (($line < 0) || ($line > $#{$lines})) {\n"
        "    return undef;\n"
        "  } else {\n"
        "    return $lines->[$line];\n"
        "  }\n"
        "}\n"
        "\n"
        "# Print disassembly for one routine with interspersed source if available\n"
        "sub PrintDisassembledFunction {\n"
        "  my $prog = shift;\n"
        "  my $offset = shift;\n"
        "  my $routine = shift;\n"
        "  my $flat = shift;\n"
        "  my $cumulative = shift;\n"
        "  my $start_addr = shift;\n"
        "  my $end_addr = shift;\n"
        "  my $total = shift;\n"
        "\n"
        "  # Disassemble all instructions\n"
        "  my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);\n"
        "\n"
        "  # Make array of counts per instruction\n"
        "  my @flat_count = ();\n"
        "  my @cum_count = ();\n"
        "  my $flat_total = 0;\n"
        "  my $cum_total = 0;\n"
        "  foreach my $e (@instructions) {\n"
        "    # Add up counts for all address that fall inside this instruction\n"
        "    my $c1 = 0;\n"
        "    my $c2 = 0;\n"
        "    for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {\n"
        "      $c1 += GetEntry($flat, $a);\n"
        "      $c2 += GetEntry($cumulative, $a);\n"
        "    }\n"
        "    push(@flat_count, $c1);\n"
        "    push(@cum_count, $c2);\n"
        "    $flat_total += $c1;\n"
        "    $cum_total += $c2;\n"
        "  }\n"
        "\n"
        "  # Print header with total counts\n"
        "  printf(\"ROUTINE ====================== %s\\n\" .\n"
        "         \"%6s %6s %s (flat, cumulative) %.1f%% of total\\n\",\n"
        "         ShortFunctionName($routine),\n"
        "         Unparse($flat_total),\n"
        "         Unparse($cum_total),\n"
        "         Units(),\n"
        "         ($cum_total * 100.0) / $total);\n"
        "\n"
        "  # Process instructions in order\n"
        "  my $current_file = \"\";\n"
        "  for (my $i = 0; $i <= $#instructions; ) {\n"
        "    my $e = $instructions[$i];\n"
        "\n"
        "    # Print the new file name whenever we switch files\n"
        "    if ($e->[1] ne $current_file) {\n"
        "      $current_file = $e->[1];\n"
        "      my $fname = $current_file;\n"
        "      $fname =~ s|^\\./||;   # Trim leading \"./\"\n"
        "\n"
        "      # Shorten long file names\n"
        "      if (length($fname) >= 58) {\n"
        "        $fname = \"...\" . substr($fname, -55);\n"
        "      }\n"
        "      printf(\"-------------------- %s\\n\", $fname);\n"
        "    }\n"
        "\n"
        "    # TODO: Compute range of lines to print together to deal with\n"
        "    # small reorderings.\n"
        "    my $first_line = $e->[2];\n"
        "    my $last_line = $first_line;\n"
        "    my %flat_sum = ();\n"
        "    my %cum_sum = ();\n"
        "    for (my $l = $first_line; $l <= $last_line; $l++) {\n"
        "      $flat_sum{$l} = 0;\n"
        "      $cum_sum{$l} = 0;\n"
        "    }\n"
        "\n"
        "    # Find run of instructions for this range of source lines\n"
        "    my $first_inst = $i;\n"
        "    while (($i <= $#instructions) &&\n"
        "           ($instructions[$i]->[2] >= $first_line) &&\n"
        "           ($instructions[$i]->[2] <= $last_line)) {\n"
        "      $e = $instructions[$i];\n"
        "      $flat_sum{$e->[2]} += $flat_count[$i];\n"
        "      $cum_sum{$e->[2]} += $cum_count[$i];\n"
        "      $i++;\n"
        "    }\n"
        "    my $last_inst = $i - 1;\n"
        "\n"
        "    # Print source lines\n"
        "    for (my $l = $first_line; $l <= $last_line; $l++) {\n"
        "      my $line = SourceLine($current_file, $l);\n"
        "      if (!defined($line)) {\n"
        "        $line = \"?\\n\";\n"
        "        next;\n"
        "      } else {\n"
        "        $line =~ s/^\\s+//;\n"
        "      }\n"
        "      printf(\"%6s %6s %5d: %s\",\n"
        "             UnparseAlt($flat_sum{$l}),\n"
        "             UnparseAlt($cum_sum{$l}),\n"
        "             $l,\n"
        "             $line);\n"
        "    }\n"
        "\n"
        "    # Print disassembly\n"
        "    for (my $x = $first_inst; $x <= $last_inst; $x++) {\n"
        "      my $e = $instructions[$x];\n"
        "      printf(\"%6s %6s    %8s: %6s\\n\",\n"
        "             UnparseAlt($flat_count[$x]),\n"
        "             UnparseAlt($cum_count[$x]),\n"
        "             UnparseAddress($offset, $e->[0]),\n"
        "             CleanDisassembly($e->[3]));\n"
        "    }\n"
        "  }\n"
        "}\n"
        "\n"
        "# Print DOT graph\n"
        "sub PrintDot {\n"
        "  my $prog = shift;\n"
        "  my $symbols = shift;\n"
        "  my $raw = shift;\n"
        "  my $flat = shift;\n"
        "  my $cumulative = shift;\n"
        "  my $overall_total = shift;\n"
        "\n"
        "  # Get total\n"
        "  my $local_total = TotalProfile($flat);\n"
        "  my $nodelimit = int($main::opt_nodefraction * $local_total);\n"
        "  my $edgelimit = int($main::opt_edgefraction * $local_total);\n"
        "  my $nodecount = $main::opt_nodecount;\n"
        "\n"
        "  # Find nodes to include\n"
        "  my @list = (sort { abs(GetEntry($cumulative, $b)) <=>\n"
        "                     abs(GetEntry($cumulative, $a))\n"
        "                     || $a cmp $b }\n"
        "              keys(%{$cumulative}));\n"
        "  my $last = $nodecount - 1;\n"
        "  if ($last > $#list) {\n"
        "    $last = $#list;\n"
        "  }\n"
        "  while (($last >= 0) &&\n"
        "         (abs(GetEntry($cumulative, $list[$last])) <= $nodelimit)) {\n"
        "    $last--;\n"
        "  }\n"
        "  if ($last < 0) {\n"
        "    print STDERR \"No nodes to print\\n\";\n"
        "    return 0;\n"
        "  }\n"
        "\n"
        "  if ($nodelimit > 0 || $edgelimit > 0) {\n"
        "    printf STDERR (\"Dropping nodes with <= %s %s; edges with <= %s abs(%s)\\n\",\n"
        "                   Unparse($nodelimit), Units(),\n"
        "                   Unparse($edgelimit), Units());\n"
        "  }\n"
        "\n"
        "  # Open DOT output file\n"
        "  my $output;\n"
        "  my $escaped_dot = ShellEscape(@DOT);\n"
        "  my $escaped_ps2pdf = ShellEscape(@PS2PDF);\n"
        "  if ($main::opt_gv) {\n"
        "    my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, \"ps\"));\n"
        "    $output = \"| $escaped_dot -Tps2 >$escaped_outfile\";\n"
        "  } elsif ($main::opt_evince) {\n"
        "    my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, \"pdf\"));\n"
        "    $output = \"| $escaped_dot -Tps2 | $escaped_ps2pdf - $escaped_outfile\";\n"
        "  } elsif ($main::opt_ps) {\n"
        "    $output = \"| $escaped_dot -Tps2\";\n"
        "  } elsif ($main::opt_pdf) {\n"
        "    $output = \"| $escaped_dot -Tps2 | $escaped_ps2pdf - -\";\n"
        "  } elsif ($main::opt_web || $main::opt_svg) {\n"
        "    # We need to post-process the SVG, so write to a temporary file always.\n"
        "    my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, \"svg\"));\n"
        "    $output = \"| $escaped_dot -Tsvg >$escaped_outfile\";\n"
        "  } elsif ($main::opt_gif) {\n"
        "    $output = \"| $escaped_dot -Tgif\";\n"
        "  } else {\n"
        "    $output = \">&STDOUT\";\n"
        "  }\n"
        "  open(DOT, $output) || error(\"$output: $!\\n\");\n"
        "\n"
        "  # Title\n"
        "  printf DOT (\"digraph \\\"%s; %s %s\\\" {\\n\",\n"
        "              $prog,\n"
        "              Unparse($overall_total),\n"
        "              Units());\n"
        "  if ($main::opt_pdf) {\n"
        "    # The output is more printable if we set the page size for dot.\n"
        "    printf DOT (\"size=\\\"8,11\\\"\\n\");\n"
        "  }\n"
        "  printf DOT (\"node [width=0.375,height=0.25];\\n\");\n"
        "\n"
        "  # Print legend\n"
        "  printf DOT (\"Legend [shape=box,fontsize=24,shape=plaintext,\" .\n"
        "              \"label=\\\"%s\\\\l%s\\\\l%s\\\\l%s\\\\l%s\\\\l\\\"];\\n\",\n"
        "              $prog,\n"
        "              sprintf(\"Total %s: %s\", Units(), Unparse($overall_total)),\n"
        "              sprintf(\"Focusing on: %s\", Unparse($local_total)),\n"
        "              sprintf(\"Dropped nodes with <= %s abs(%s)\",\n"
        "                      Unparse($nodelimit), Units()),\n"
        "              sprintf(\"Dropped edges with <= %s %s\",\n"
        "                      Unparse($edgelimit), Units())\n"
        "              );\n"
        "\n"
        "  # Print nodes\n"
        "  my %node = ();\n"
        "  my $nextnode = 1;\n"
        "  foreach my $a (@list[0..$last]) {\n"
        "    # Pick font size\n"
        "    my $f = GetEntry($flat, $a);\n"
        "    my $c = GetEntry($cumulative, $a);\n"
        "\n"
        "    my $fs = 8;\n"
        "    if ($local_total > 0) {\n"
        "      $fs = 8 + (50.0 * sqrt(abs($f * 1.0 / $local_total)));\n"
        "    }\n"
        "\n"
        "    $node{$a} = $nextnode++;\n"
        "    my $sym = $a;\n"
        "    $sym =~ s/\\s+/\\\\n/g;\n"
        "    $sym =~ s/::/\\\\n/g;\n"
        "\n"
        "    # Extra cumulative info to print for non-leaves\n"
        "    my $extra = \"\";\n"
        "    if ($f != $c) {\n"
        "      $extra = sprintf(\"\\\\rof %s (%s)\",\n"
        "                       Unparse($c),\n"
        "                       Percent($c, $local_total));\n"
        "    }\n"
        "    my $style = \"\";\n"
        "    if ($main::opt_heapcheck) {\n"
        "      if ($f > 0) {\n"
        "        # make leak-causing nodes more visible (add a background)\n"
        "        $style = \",style=filled,fillcolor=gray\"\n"
        "      } elsif ($f < 0) {\n"
        "        # make anti-leak-causing nodes (which almost never occur)\n"
        "        # stand out as well (triple border)\n"
        "        $style = \",peripheries=3\"\n"
        "      }\n"
        "    }\n"
        "\n"
        "    printf DOT (\"N%d [label=\\\"%s\\\\n%s (%s)%s\\\\r\" .\n"
        "                \"\\\",shape=box,fontsize=%.1f%s];\\n\",\n"
        "                $node{$a},\n"
        "                $sym,\n"
        "                Unparse($f),\n"
        "                Percent($f, $local_total),\n"
        "                $extra,\n"
        "                $fs,\n"
        "                $style,\n"
        "               );\n"
        "  }\n"
        "\n"
        "  # Get edges and counts per edge\n"
        "  my %edge = ();\n"
        "  my $n;\n"
        "  my $fullname_to_shortname_map = {};\n"
        "  FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map);\n"
        "  foreach my $k (keys(%{$raw})) {\n"
        "    # TODO: omit low %age edges\n"
        "    $n = $raw->{$k};\n"
        "    my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k);\n"
        "    for (my $i = 1; $i <= $#translated; $i++) {\n"
        "      my $src = $translated[$i];\n"
        "      my $dst = $translated[$i-1];\n"
        "      #next if ($src eq $dst);  # Avoid self-edges?\n"
        "      if (exists($node{$src}) && exists($node{$dst})) {\n"
        "        my $edge_label = \"$src\\001$dst\";\n"
        "        if (!exists($edge{$edge_label})) {\n"
        "          $edge{$edge_label} = 0;\n"
        "        }\n"
        "        $edge{$edge_label} += $n;\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "\n"
        "  # Print edges (process in order of decreasing counts)\n"
        "  my %indegree = ();   # Number of incoming edges added per node so far\n"
        "  my %outdegree = ();  # Number of outgoing edges added per node so far\n"
        "  foreach my $e (sort { $edge{$b} <=> $edge{$a} } keys(%edge)) {\n"
        "    my @x = split(/\\001/, $e);\n"
        "    $n = $edge{$e};\n"
        "\n"
        "    # Initialize degree of kept incoming and outgoing edges if necessary\n"
        "    my $src = $x[0];\n"
        "    my $dst = $x[1];\n"
        "    if (!exists($outdegree{$src})) { $outdegree{$src} = 0; }\n"
        "    if (!exists($indegree{$dst})) { $indegree{$dst} = 0; }\n"
        "\n"
        "    my $keep;\n"
        "    if ($indegree{$dst} == 0) {\n"
        "      # Keep edge if needed for reachability\n"
        "      $keep = 1;\n"
        "    } elsif (abs($n) <= $edgelimit) {\n"
        "      # Drop if we are below --edgefraction\n"
        "      $keep = 0;\n"
        "    } elsif ($outdegree{$src} >= $main::opt_maxdegree ||\n"
        "             $indegree{$dst} >= $main::opt_maxdegree) {\n"
        "      # Keep limited number of in/out edges per node\n"
        "      $keep = 0;\n"
        "    } else {\n"
        "      $keep = 1;\n"
        "    }\n"
        "\n"
        "    if ($keep) {\n"
        "      $outdegree{$src}++;\n"
        "      $indegree{$dst}++;\n"
        "\n"
        "      # Compute line width based on edge count\n"
        "      my $fraction = abs($local_total ? (3 * ($n / $local_total)) : 0);\n"
        "      if ($fraction > 1) { $fraction = 1; }\n"
        "      my $w = $fraction * 2;\n"
        "      if ($w < 1 && ($main::opt_web || $main::opt_svg)) {\n"
        "        # SVG output treats line widths < 1 poorly.\n"
        "        $w = 1;\n"
        "      }\n"
        "\n"
        "      # Dot sometimes segfaults if given edge weights that are too large, so\n"
        "      # we cap the weights at a large value\n"
        "      my $edgeweight = abs($n) ** 0.7;\n"
        "      if ($edgeweight > 100000) { $edgeweight = 100000; }\n"
        "      $edgeweight = int($edgeweight);\n"
        "\n"
        "      my $style = sprintf(\"setlinewidth(%f)\", $w);\n"
        "      if ($x[1] =~ m/\\(inline\\)/) {\n"
        "        $style .= \",dashed\";\n"
        "      }\n"
        "\n"
        "      # Use a slightly squashed function of the edge count as the weight\n"
        "      printf DOT (\"N%s -> N%s [label=%s, weight=%d, style=\\\"%s\\\"];\\n\",\n"
        "                  $node{$x[0]},\n"
        "                  $node{$x[1]},\n"
        "                  Unparse($n),\n"
        "                  $edgeweight,\n"
        "                  $style);\n"
        "    }\n"
        "  }\n"
        "\n"
        "  print DOT (\"}\\n\");\n"
        "  close(DOT);\n"
        "\n"
        "  if ($main::opt_web || $main::opt_svg) {\n"
        "    # Rewrite SVG to be more usable inside web browser.\n"
        "    RewriteSvg(TempName($main::next_tmpfile, \"svg\"));\n"
        "  }\n"
        "\n"
        "  return 1;\n"
        "}\n"
        "\n"
        "sub RewriteSvg {\n"
        "  my $svgfile = shift;\n"
        "\n"
        "  open(SVG, $svgfile) || die \"open temp svg: $!\";\n"
        "  my @svg = <SVG>;\n"
        "  close(SVG);\n"
        "  unlink $svgfile;\n"
        "  my $svg = join('', @svg);\n"
        "\n"
        "  # Dot's SVG output is\n"
        "  #\n"
        "  #    <svg width=\"___\" height=\"___\"\n"
        "  #     viewBox=\"___\" xmlns=...>\n"
        "  #    <g id=\"graph0\" transform=\"...\">\n"
        "  #    ...\n"
        "  #    </g>\n"
        "  #    </svg>\n"
        "  #\n"
        "  # Change it to\n"
        "  #\n"
        "  #    <svg width=\"100%\" height=\"100%\"\n"
        "  #     xmlns=...>\n"
        "  #    $svg_javascript\n"
        "  #    <g id=\"viewport\" transform=\"translate(0,0)\">\n"
        "  #    <g id=\"graph0\" transform=\"...\">\n"
        "  #    ...\n"
        "  #    </g>\n"
        "  #    </g>\n"
        "  #    </svg>\n"
        "\n"
        "  # Fix width, height; drop viewBox.\n"
        "  $svg =~ s/(?s)<svg width=\"[^\"]+\" height=\"[^\"]+\"(.*?)viewBox=\"[^\"]+\"/<svg "
        "width=\"100%\" height=\"100%\"$1/;\n"
        "\n"
        "  # Insert script, viewport <g> above first <g>\n"
        "  my $svg_javascript = SvgJavascript();\n"
        "  my $viewport = \"<g id=\\\"viewport\\\" transform=\\\"translate(0,0)\\\">\\n\";\n"
        "  $svg =~ s/<g id=\"graph\\d\"/$svg_javascript$viewport$&/;\n"
        "\n"
        "  # Insert final </g> above </svg>.\n"
        "  $svg =~ s/(.*)(<\\/svg>)/$1<\\/g>$2/;\n"
        "  $svg =~ s/<g id=\"graph\\d\"(.*?)/<g id=\"viewport\"$1/;\n"
        "\n"
        "  if ($main::opt_svg) {\n"
        "    # --svg: write to standard output.\n"
        "    print $svg;\n"
        "  } else {\n"
        "    # Write back to temporary file.\n"
        "    open(SVG, \">$svgfile\") || die \"open $svgfile: $!\";\n"
        "    print SVG $svg;\n"
        "    close(SVG);\n"
        "  }\n"
        "}\n"
        "\n"
        "sub SvgJavascript {\n"
        "  return <<'EOF';\n"
        "<script type=\"text/ecmascript\"><![CDATA[\n"
        "// SVGPan\n"
        "// http://www.cyberz.org/blog/2009/12/08/svgpan-a-javascript-svg-panzoomdrag-library/\n"
        "// Local modification: if(true || ...) below to force panning, never moving.\n"
        "/**\n"
        " *  SVGPan library 1.2\n"
        " * ====================\n"
        " *\n"
        " * Given an unique existing element with id \"viewport\", including the\n"
        " * the library into any SVG adds the following capabilities:\n"
        " *\n"
        " *  - Mouse panning\n"
        " *  - Mouse zooming (using the wheel)\n"
        " *  - Object dargging\n"
        " *\n"
        " * Known issues:\n"
        " *\n"
        " *  - Zooming (while panning) on Safari has still some issues\n"
        " *\n"
        " * Releases:\n"
        " *\n"
        " * 1.2, Sat Mar 20 08:42:50 GMT 2010, Zeng Xiaohui\n"
        " *	Fixed a bug with browser mouse handler interaction\n"
        " *\n"
        " * 1.1, Wed Feb  3 17:39:33 GMT 2010, Zeng Xiaohui\n"
        " *	Updated the zoom code to support the mouse wheel on Safari/Chrome\n"
        " *\n"
        " * 1.0, Andrea Leofreddi\n"
        " *	First release\n"
        " *\n"
        " * This code is licensed under the following BSD license:\n"
        " *\n"
        " * Copyright 2009-2010 Andrea Leofreddi <a.leofreddi@itcharm.com>. All rights "
        "reserved.\n"
        " *\n"
        " * Redistribution and use in source and binary forms, with or without modification, "
        "are\n"
        " * permitted provided that the following conditions are met:\n"
        " *\n"
        " *    1. Redistributions of source code must retain the above copyright notice, this "
        "list of\n"
        " *       conditions and the following disclaimer.\n"
        " *\n"
        " *    2. Redistributions in binary form must reproduce the above copyright notice, "
        "this list\n"
        " *       of conditions and the following disclaimer in the documentation and/or other "
        "materials\n"
        " *       provided with the distribution.\n"
        " *\n"
        " * THIS SOFTWARE IS PROVIDED BY Andrea Leofreddi ``AS IS'' AND ANY EXPRESS OR IMPLIED\n"
        " * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF "
        "MERCHANTABILITY AND\n"
        " * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Andrea Leofreddi "
        "OR\n"
        " * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, "
        "OR\n"
        " * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE "
        "GOODS OR\n"
        " * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED "
        "AND ON\n"
        " * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING\n"
        " * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN "
        "IF\n"
        " * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n"
        " *\n"
        " * The views and conclusions contained in the software and documentation are those of "
        "the\n"
        " * authors and should not be interpreted as representing official policies, either "
        "expressed\n"
        " * or implied, of Andrea Leofreddi.\n"
        " */\n"
        "var root = document.documentElement;\n"
        "var state = 'none', stateTarget, stateOrigin, stateTf;\n"
        "setupHandlers(root);\n"
        "/**\n"
        " * Register handlers\n"
        " */\n"
        "function setupHandlers(root){\n"
        "	setAttributes(root, {\n"
        "		\"onmouseup\" : \"add(evt)\",\n"
        "		\"onmousedown\" : \"handleMouseDown(evt)\",\n"
        "		\"onmousemove\" : \"handleMouseMove(evt)\",\n"
        "		\"onmouseup\" : \"handleMouseUp(evt)\",\n"
        "		//\"onmouseout\" : \"handleMouseUp(evt)\", // Decomment this to stop the "
        "pan functionality when dragging out of the SVG element\n"
        "	});\n"
        "	if(navigator.userAgent.toLowerCase().indexOf('webkit') >= 0)\n"
        "		window.addEventListener('mousewheel', handleMouseWheel, false); // "
        "Chrome/Safari\n"
        "	else\n"
        "		window.addEventListener('DOMMouseScroll', handleMouseWheel, false); // "
        "Others\n"
        "	var g = svgDoc.getElementById(\"svg\");\n"
        "	g.width = \"100%\";\n"
        "	g.height = \"100%\";\n"
        "}\n"
        "/**\n"
        " * Instance an SVGPoint object with given event coordinates.\n"
        " */\n"
        "function getEventPoint(evt) {\n"
        "	var p = root.createSVGPoint();\n"
        "	p.x = evt.clientX;\n"
        "	p.y = evt.clientY;\n"
        "	return p;\n"
        "}\n"
        "/**\n"
        " * Sets the current transform matrix of an element.\n"
        " */\n"
        "function setCTM(element, matrix) {\n"
        "	var s = \"matrix(\" + matrix.a + \",\" + matrix.b + \",\" + matrix.c + \",\" + "
        "matrix.d + \",\" + matrix.e + \",\" + matrix.f + \")\";\n"
        "	element.setAttribute(\"transform\", s);\n"
        "}\n"
        "/**\n"
        " * Dumps a matrix to a string (useful for debug).\n"
        " */\n"
        "function dumpMatrix(matrix) {\n"
        "	var s = \"[ \" + matrix.a + \", \" + matrix.c + \", \" + matrix.e + \"\\n  \" + "
        "matrix.b + \", \" + matrix.d + \", \" + matrix.f + \"\\n  0, 0, 1 ]\";\n"
        "	return s;\n"
        "}\n"
        "/**\n"
        " * Sets attributes of an element.\n"
        " */\n"
        "function setAttributes(element, attributes){\n"
        "	for (i in attributes)\n"
        "		element.setAttributeNS(null, i, attributes[i]);\n"
        "}\n"
        "/**\n"
        " * Handle mouse move event.\n"
        " */\n"
        "function handleMouseWheel(evt) {\n"
        "	if(evt.preventDefault)\n"
        "		evt.preventDefault();\n"
        "	evt.returnValue = false;\n"
        "	var svgDoc = evt.target.ownerDocument;\n"
        "	var delta;\n"
        "	if(evt.wheelDelta)\n"
        "		delta = evt.wheelDelta / 3600; // Chrome/Safari\n"
        "	else\n"
        "		delta = evt.detail / -90; // Mozilla\n"
        "	var z = 1 + delta; // Zoom factor: 0.9/1.1\n"
        "	var g = svgDoc.getElementById(\"viewport\");\n"
        "	var p = getEventPoint(evt);\n"
        "	p = p.matrixTransform(g.getCTM().inverse());\n"
        "	// Compute new scale matrix in current mouse position\n"
        "	var k = root.createSVGMatrix().translate(p.x, p.y).scale(z).translate(-p.x, "
        "-p.y);\n"
        "        setCTM(g, g.getCTM().multiply(k));\n"
        "	stateTf = stateTf.multiply(k.inverse());\n"
        "}\n"
        "/**\n"
        " * Handle mouse move event.\n"
        " */\n"
        "function handleMouseMove(evt) {\n"
        "	if(evt.preventDefault)\n"
        "		evt.preventDefault();\n"
        "	evt.returnValue = false;\n"
        "	var svgDoc = evt.target.ownerDocument;\n"
        "	var g = svgDoc.getElementById(\"viewport\");\n"
        "	if(state == 'pan') {\n"
        "		// Pan mode\n"
        "		var p = getEventPoint(evt).matrixTransform(stateTf);\n"
        "		setCTM(g, stateTf.inverse().translate(p.x - stateOrigin.x, p.y - "
        "stateOrigin.y));\n"
        "	} else if(state == 'move') {\n"
        "		// Move mode\n"
        "		var p = getEventPoint(evt).matrixTransform(g.getCTM().inverse());\n"
        "		setCTM(stateTarget, root.createSVGMatrix().translate(p.x - stateOrigin.x, "
        "p.y - stateOrigin.y).multiply(g.getCTM().inverse()).multiply(stateTarget.getCTM()));\n"
        "		stateOrigin = p;\n"
        "	}\n"
        "}\n"
        "/**\n"
        " * Handle click event.\n"
        " */\n"
        "function handleMouseDown(evt) {\n"
        "	if(evt.preventDefault)\n"
        "		evt.preventDefault();\n"
        "	evt.returnValue = false;\n"
        "	var svgDoc = evt.target.ownerDocument;\n"
        "	var g = svgDoc.getElementById(\"viewport\");\n"
        "	if(true || evt.target.tagName == \"svg\") {\n"
        "		// Pan mode\n"
        "		state = 'pan';\n"
        "		stateTf = g.getCTM().inverse();\n"
        "		stateOrigin = getEventPoint(evt).matrixTransform(stateTf);\n"
        "	} else {\n"
        "		// Move mode\n"
        "		state = 'move';\n"
        "		stateTarget = evt.target;\n"
        "		stateTf = g.getCTM().inverse();\n"
        "		stateOrigin = getEventPoint(evt).matrixTransform(stateTf);\n"
        "	}\n"
        "}\n"
        "/**\n"
        " * Handle mouse button release event.\n"
        " */\n"
        "function handleMouseUp(evt) {\n"
        "	if(evt.preventDefault)\n"
        "		evt.preventDefault();\n"
        "	evt.returnValue = false;\n"
        "	var svgDoc = evt.target.ownerDocument;\n"
        "	if(state == 'pan' || state == 'move') {\n"
        "		// Quit pan mode\n"
        "		state = '';\n"
        "	}\n"
        "}\n"
        "]]></script>\n"
        "EOF\n"
        "}\n"
        "\n"
        "# Provides a map from fullname to shortname for cases where the\n"
        "# shortname is ambiguous.  The symlist has both the fullname and\n"
        "# shortname for all symbols, which is usually fine, but sometimes --\n"
        "# such as overloaded functions -- two different fullnames can map to\n"
        "# the same shortname.  In that case, we use the address of the\n"
        "# function to disambiguate the two.  This function fills in a map that\n"
        "# maps fullnames to modified shortnames in such cases.  If a fullname\n"
        "# is not present in the map, the 'normal' shortname provided by the\n"
        "# symlist is the appropriate one to use.\n"
        "sub FillFullnameToShortnameMap {\n"
        "  my $symbols = shift;\n"
        "  my $fullname_to_shortname_map = shift;\n"
        "  my $shortnames_seen_once = {};\n"
        "  my $shortnames_seen_more_than_once = {};\n"
        "\n"
        "  foreach my $symlist (values(%{$symbols})) {\n"
        "    # TODO(csilvers): deal with inlined symbols too.\n"
        "    my $shortname = $symlist->[0];\n"
        "    my $fullname = $symlist->[2];\n"
        "    if ($fullname !~ /<[0-9a-fA-F]+>$/) {  # fullname doesn't end in an address\n"
        "      next;       # the only collisions we care about are when addresses differ\n"
        "    }\n"
        "    if (defined($shortnames_seen_once->{$shortname}) &&\n"
        "        $shortnames_seen_once->{$shortname} ne $fullname) {\n"
        "      $shortnames_seen_more_than_once->{$shortname} = 1;\n"
        "    } else {\n"
        "      $shortnames_seen_once->{$shortname} = $fullname;\n"
        "    }\n"
        "  }\n"
        "\n"
        "  foreach my $symlist (values(%{$symbols})) {\n"
        "    my $shortname = $symlist->[0];\n"
        "    my $fullname = $symlist->[2];\n"
        "    # TODO(csilvers): take in a list of addresses we care about, and only\n"
        "    # store in the map if $symlist->[1] is in that list.  Saves space.\n"
        "    next if defined($fullname_to_shortname_map->{$fullname});\n"
        "    if (defined($shortnames_seen_more_than_once->{$shortname})) {\n"
        "      if ($fullname =~ /<0*([^>]*)>$/) {   # fullname has address at end of it\n"
        "        $fullname_to_shortname_map->{$fullname} = \"$shortname\\@$1\";\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "}\n"
        "\n"
        "# Return a small number that identifies the argument.\n"
        "# Multiple calls with the same argument will return the same number.\n"
        "# Calls with different arguments will return different numbers.\n"
        "sub ShortIdFor {\n"
        "  my $key = shift;\n"
        "  my $id = $main::uniqueid{$key};\n"
        "  if (!defined($id)) {\n"
        "    $id = keys(%main::uniqueid) + 1;\n"
        "    $main::uniqueid{$key} = $id;\n"
        "  }\n"
        "  return $id;\n"
        "}\n"
        "\n"
        "# Translate a stack of addresses into a stack of symbols\n"
        "sub TranslateStack {\n"
        "  my $symbols = shift;\n"
        "  my $fullname_to_shortname_map = shift;\n"
        "  my $k = shift;\n"
        "\n"
        "  my @addrs = split(/\\n/, $k);\n"
        "  my @result = ();\n"
        "  for (my $i = 0; $i <= $#addrs; $i++) {\n"
        "    my $a = $addrs[$i];\n"
        "\n"
        "    # Skip large addresses since they sometimes show up as fake entries on RH9\n"
        "    if (length($a) > 8 && $a gt \"7fffffffffffffff\") {\n"
        "      next;\n"
        "    }\n"
        "\n"
        "    if ($main::opt_disasm || $main::opt_list) {\n"
        "      # We want just the address for the key\n"
        "      push(@result, $a);\n"
        "      next;\n"
        "    }\n"
        "\n"
        "    my $symlist = $symbols->{$a};\n"
        "    if (!defined($symlist)) {\n"
        "      $symlist = [$a, \"\", $a];\n"
        "    }\n"
        "\n"
        "    # We can have a sequence of symbols for a particular entry\n"
        "    # (more than one symbol in the case of inlining).  Callers\n"
        "    # come before callees in symlist, so walk backwards since\n"
        "    # the translated stack should contain callees before callers.\n"
        "    for (my $j = $#{$symlist}; $j >= 2; $j -= 3) {\n"
        "      my $func = $symlist->[$j-2];\n"
        "      my $fileline = $symlist->[$j-1];\n"
        "      my $fullfunc = $symlist->[$j];\n"
        "      if (defined($fullname_to_shortname_map->{$fullfunc})) {\n"
        "        $func = $fullname_to_shortname_map->{$fullfunc};\n"
        "      }\n"
        "      if ($j > 2) {\n"
        "        $func = \"$func (inline)\";\n"
        "      }\n"
        "\n"
        "      # Do not merge nodes corresponding to Callback::Run since that\n"
        "      # causes confusing cycles in dot display.  Instead, we synthesize\n"
        "      # a unique name for this frame per caller.\n"
        "      if ($func =~ m/Callback.*::Run$/) {\n"
        "        my $caller = ($i > 0) ? $addrs[$i-1] : 0;\n"
        "        $func = \"Run#\" . ShortIdFor($caller);\n"
        "      }\n"
        "\n"
        "      if ($main::opt_addresses) {\n"
        "        push(@result, \"$a $func $fileline\");\n"
        "      } elsif ($main::opt_lines) {\n"
        "        if ($func eq '\?\?' && $fileline eq '\?\?:0') {\n"
        "          push(@result, \"$a\");\n"
        "        } elsif (!$main::opt_show_addresses) {\n"
        "          push(@result, \"$func $fileline\");\n"
        "        } else {\n"
        "          push(@result, \"$func $fileline ($a)\");\n"
        "        }\n"
        "      } elsif ($main::opt_functions) {\n"
        "        if ($func eq '\?\?') {\n"
        "          push(@result, \"$a\");\n"
        "        } elsif (!$main::opt_show_addresses) {\n"
        "          push(@result, $func);\n"
        "        } else {\n"
        "          push(@result, \"$func ($a)\");\n"
        "        }\n"
        "      } elsif ($main::opt_files) {\n"
        "        if ($fileline eq '\?\?:0' || $fileline eq '') {\n"
        "          push(@result, \"$a\");\n"
        "        } else {\n"
        "          my $f = $fileline;\n"
        "          $f =~ s/:\\d+$//;\n"
        "          push(@result, $f);\n"
        "        }\n"
        "      } else {\n"
        "        push(@result, $a);\n"
        "        last;  # Do not print inlined info\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "\n"
        "  # print join(\",\", @addrs), \" => \", join(\",\", @result), \"\\n\";\n"
        "  return @result;\n"
        "}\n"
        "\n"
        "# Generate percent string for a number and a total\n"
        "sub Percent {\n"
        "  my $num = shift;\n"
        "  my $tot = shift;\n"
        "  if ($tot != 0) {\n"
        "    return sprintf(\"%.1f%%\", $num * 100.0 / $tot);\n"
        "  } else {\n"
        "    return ($num == 0) ? \"nan\" : (($num > 0) ? \"+inf\" : \"-inf\");\n"
        "  }\n"
        "}\n"
        "\n"
        "# Generate pretty-printed form of number\n"
        "sub Unparse {\n"
        "  my $num = shift;\n"
        "  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {\n"
        "    if ($main::opt_inuse_objects || $main::opt_alloc_objects) {\n"
        "      return sprintf(\"%d\", $num);\n"
        "    } else {\n"
        "      if ($main::opt_show_bytes) {\n"
        "        return sprintf(\"%d\", $num);\n"
        "      } else {\n"
        "        return sprintf(\"%.1f\", $num / 1048576.0);\n"
        "      }\n"
        "    }\n"
        "  } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {\n"
        "    return sprintf(\"%.3f\", $num / 1e9); # Convert nanoseconds to seconds\n"
        "  } else {\n"
        "    return sprintf(\"%d\", $num);\n"
        "  }\n"
        "}\n"
        "\n"
        "# Alternate pretty-printed form: 0 maps to \".\"\n"
        "sub UnparseAlt {\n"
        "  my $num = shift;\n"
        "  if ($num == 0) {\n"
        "    return \".\";\n"
        "  } else {\n"
        "    return Unparse($num);\n"
        "  }\n"
        "}\n"
        "\n"
        "# Alternate pretty-printed form: 0 maps to \"\"\n"
        "sub HtmlPrintNumber {\n"
        "  my $num = shift;\n"
        "  if ($num == 0) {\n"
        "    return \"\";\n"
        "  } else {\n"
        "    return Unparse($num);\n"
        "  }\n"
        "}\n"
        "\n"
        "# Return output units\n"
        "sub Units {\n"
        "  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {\n"
        "    if ($main::opt_inuse_objects || $main::opt_alloc_objects) {\n"
        "      return \"objects\";\n"
        "    } else {\n"
        "      if ($main::opt_show_bytes) {\n"
        "        return \"B\";\n"
        "      } else {\n"
        "        return \"MB\";\n"
        "      }\n"
        "    }\n"
        "  } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {\n"
        "    return \"seconds\";\n"
        "  } else {\n"
        "    return \"samples\";\n"
        "  }\n"
        "}\n"
        "\n"
        "##### Profile manipulation code #####\n"
        "\n"
        "# Generate flattened profile:\n"
        "# If count is charged to stack [a,b,c,d], in generated profile,\n"
        "# it will be charged to [a]\n"
        "sub FlatProfile {\n"
        "  my $profile = shift;\n"
        "  my $result = {};\n"
        "  foreach my $k (keys(%{$profile})) {\n"
        "    my $count = $profile->{$k};\n"
        "    my @addrs = split(/\\n/, $k);\n"
        "    if ($#addrs >= 0) {\n"
        "      AddEntry($result, $addrs[0], $count);\n"
        "    }\n"
        "  }\n"
        "  return $result;\n"
        "}\n"
        "\n"
        "# Generate cumulative profile:\n"
        "# If count is charged to stack [a,b,c,d], in generated profile,\n"
        "# it will be charged to [a], [b], [c], [d]\n"
        "sub CumulativeProfile {\n"
        "  my $profile = shift;\n"
        "  my $result = {};\n"
        "  foreach my $k (keys(%{$profile})) {\n"
        "    my $count = $profile->{$k};\n"
        "    my @addrs = split(/\\n/, $k);\n"
        "    foreach my $a (@addrs) {\n"
        "      AddEntry($result, $a, $count);\n"
        "    }\n"
        "  }\n"
        "  return $result;\n"
        "}\n"
        "\n"
        "# If the second-youngest PC on the stack is always the same, returns\n"
        "# that pc.  Otherwise, returns undef.\n"
        "sub IsSecondPcAlwaysTheSame {\n"
        "  my $profile = shift;\n"
        "\n"
        "  my $second_pc = undef;\n"
        "  foreach my $k (keys(%{$profile})) {\n"
        "    my @addrs = split(/\\n/, $k);\n"
        "    if ($#addrs < 1) {\n"
        "      return undef;\n"
        "    }\n"
        "    if (not defined $second_pc) {\n"
        "      $second_pc = $addrs[1];\n"
        "    } else {\n"
        "      if ($second_pc ne $addrs[1]) {\n"
        "        return undef;\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "  return $second_pc;\n"
        "}\n"
        "\n"
        "sub ExtractSymbolLocationInlineStack {\n"
        "  my $symbols = shift;\n"
        "  my $address = shift;\n"
        "  my $stack = shift;\n"
        "  # 'addr2line' outputs \"\?\?:0\" for unknown locations; we do the\n"
        "  # same to be consistent.\n"
        "  if (exists $symbols->{$address}) {\n"
        "    my @localinlinestack = @{$symbols->{$address}};\n"
        "    for (my $i = $#localinlinestack; $i > 0; $i-=3) {\n"
        "      my $file = $localinlinestack[$i-1];\n"
        "      my $fn = $localinlinestack[$i-2];\n"
        "      if ($file eq \"?\" || $file eq \":0\") {\n"
        "        $file = \"\?\?:0\";\n"
        "      }\n"
        "      my $suffix = \"[inline]\";\n"
        "      if ($i == 2) {\n"
        "        $suffix = \"\";\n"
        "      }\n"
        "      push (@$stack, $file.\":\".$fn.$suffix);\n"
        "    }\n"
        "  }\n"
        "  else {\n"
        "      push (@$stack, \"\?\?:0:unknown\");\n"
        "  }\n"
        "}\n"
        "\n"
        "sub ExtractSymbolNameInlineStack {\n"
        "  my $symbols = shift;\n"
        "  my $address = shift;\n"
        "\n"
        "  my @stack = ();\n"
        "\n"
        "  if (exists $symbols->{$address}) {\n"
        "    my @localinlinestack = @{$symbols->{$address}};\n"
        "    for (my $i = $#localinlinestack; $i > 0; $i-=3) {\n"
        "      my $file = $localinlinestack[$i-1];\n"
        "      my $fn = $localinlinestack[$i-0];\n"
        "\n"
        "      if ($file eq \"?\" || $file eq \":0\") {\n"
        "        $file = \"\?\?:0\";\n"
        "      }\n"
        "      if ($fn eq '\?\?') {\n"
        "        # If we can't get the symbol name, at least use the file information.\n"
        "        $fn = $file;\n"
        "      }\n"
        "      my $suffix = \"[inline]\";\n"
        "      if ($i == 2) {\n"
        "        $suffix = \"\";\n"
        "      }\n"
        "      push (@stack, $fn.$suffix);\n"
        "    }\n"
        "  }\n"
        "  else {\n"
        "    # If we can't get a symbol name, at least fill in the address.\n"
        "    push (@stack, $address);\n"
        "  }\n"
        "\n"
        "  return @stack;\n"
        "}\n"
        "\n"
        "sub ExtractSymbolLocation {\n"
        "  my $symbols = shift;\n"
        "  my $address = shift;\n"
        "  # 'addr2line' outputs \"\?\?:0\" for unknown locations; we do the\n"
        "  # same to be consistent.\n"
        "  my $location = \"\?\?:0:unknown\";\n"
        "  if (exists $symbols->{$address}) {\n"
        "    my $file = $symbols->{$address}->[1];\n"
        "    if ($file eq \"?\" || $file eq \":0\") {\n"
        "      $file = \"\?\?:0\"\n"
        "    }\n"
        "    $location = $file . \":\" . $symbols->{$address}->[0];\n"
        "  }\n"
        "  return $location;\n"
        "}\n"
        "\n"
        "# Extracts a graph of calls.\n"
        "sub ExtractCalls {\n"
        "  my $symbols = shift;\n"
        "  my $profile = shift;\n"
        "  my $calls = {};\n"
        "  while( my ($stack_trace, $count) = each %$profile ) {\n"
        "    my @address = split(/\\n/, $stack_trace);\n"
        "    my @stack = ();\n"
        "    ExtractSymbolLocationInlineStack($symbols, $address[0], \\@stack);\n"
        "    for (my $i = 1; $i <= $#address; $i++) {\n"
        "      ExtractSymbolLocationInlineStack($symbols, $address[$i], \\@stack);\n"
        "    }\n"
        "    AddEntry($calls, $stack[0], $count);\n"
        "    for (my $i = 1; $i < $#address; $i++) {\n"
        "      AddEntry($calls, \"$stack[$i] -> $stack[$i-1]\", $count);\n"
        "    }\n"
        "  }\n"
        "  return $calls;\n"
        "}\n"
        "\n"
        "sub PrintStacksForText {\n"
        "  my $symbols = shift;\n"
        "  my $profile = shift;\n"
        "\n"
        "  while (my ($stack_trace, $count) = each %$profile) {\n"
        "    my @address = split(/\\n/, $stack_trace);\n"
        "    for (my $i = 0; $i <= $#address; $i++) {\n"
        "      $address[$i] = sprintf(\"(%s) %s\", $address[$i], "
        "ExtractSymbolLocation($symbols, $address[$i]));\n"
        "    }\n"
        "    printf(\"%-8d %s\\n\\n\", $count, join(\"\\n         \", @address));\n"
        "  }\n"
        "}\n"
        "\n"
        "sub PrintCollapsedStacks {\n"
        "  my $symbols = shift;\n"
        "  my $profile = shift;\n"
        "\n"
        "  while (my ($stack_trace, $count) = each %$profile) {\n"
        "    my @address = split(/\\n/, $stack_trace);\n"
        "    my @names = reverse ( map { ExtractSymbolNameInlineStack($symbols, $_) } @address "
        ");\n"
        "    printf(\"%s %d\\n\", join(\";\", @names), $count);\n"
        "  }\n"
        "}\n"
        "\n"
        "sub RemoveUninterestingFrames {\n"
        "  my $symbols = shift;\n"
        "  my $profile = shift;\n"
        "\n"
        "  # List of function names to skip\n"
        "  my %skip = ();\n"
        "  my $skip_regexp = 'NOMATCH';\n"
        "  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {\n"
        "    foreach my $name ('calloc',\n"
        "                      'cfree',\n"
        "                      'malloc',\n"
        "                      'free',\n"
        "                      'memalign',\n"
        "                      'posix_memalign',\n"
        "                      'pvalloc',\n"
        "                      'valloc',\n"
        "                      'realloc',\n"
        "                      'tc_calloc',\n"
        "                      'tc_cfree',\n"
        "                      'tc_malloc',\n"
        "                      'tc_free',\n"
        "                      'tc_memalign',\n"
        "                      'tc_posix_memalign',\n"
        "                      'tc_pvalloc',\n"
        "                      'tc_valloc',\n"
        "                      'tc_realloc',\n"
        "                      'tc_new',\n"
        "                      'tc_delete',\n"
        "                      'tc_newarray',\n"
        "                      'tc_deletearray',\n"
        "                      'tc_new_nothrow',\n"
        "                      'tc_newarray_nothrow',\n"
        "                      'do_malloc',\n"
        "                      '::do_malloc',   # new name -- got moved to an unnamed ns\n"
        "                      '::do_malloc_or_cpp_alloc',\n"
        "                      'DoSampledAllocation',\n"
        "                      'simple_alloc::allocate',\n"
        "                      '__malloc_alloc_template::allocate',\n"
        "                      '__builtin_delete',\n"
        "                      '__builtin_new',\n"
        "                      '__builtin_vec_delete',\n"
        "                      '__builtin_vec_new',\n"
        "                      'operator new',\n"
        "                      'operator new[]',\n"
        "                      # The entry to our memory-allocation routines on OS X\n"
        "                      'malloc_zone_malloc',\n"
        "                      'malloc_zone_calloc',\n"
        "                      'malloc_zone_valloc',\n"
        "                      'malloc_zone_realloc',\n"
        "                      'malloc_zone_memalign',\n"
        "                      'malloc_zone_free',\n"
        "                      # These mark the beginning/end of our custom sections\n"
        "                      '__start_google_malloc',\n"
        "                      '__stop_google_malloc',\n"
        "                      '__start_malloc_hook',\n"
        "                      '__stop_malloc_hook') {\n"
        "      $skip{$name} = 1;\n"
        "      $skip{\"_\" . $name} = 1;   # Mach (OS X) adds a _ prefix to everything\n"
        "    }\n"
        "    # TODO: Remove TCMalloc once everything has been\n"
        "    # moved into the tcmalloc:: namespace and we have flushed\n"
        "    # old code out of the system.\n"
        "    $skip_regexp = \"TCMalloc|^tcmalloc::\";\n"
        "  } elsif ($main::profile_type eq 'contention') {\n"
        "    foreach my $vname ('base::RecordLockProfileData',\n"
        "                       'base::SubmitMutexProfileData',\n"
        "                       'base::SubmitSpinLockProfileData',\n"
        "                       'Mutex::Unlock',\n"
        "                       'Mutex::UnlockSlow',\n"
        "                       'Mutex::ReaderUnlock',\n"
        "                       'MutexLock::~MutexLock',\n"
        "                       'SpinLock::Unlock',\n"
        "                       'SpinLock::SlowUnlock',\n"
        "                       'SpinLockHolder::~SpinLockHolder') {\n"
        "      $skip{$vname} = 1;\n"
        "    }\n"
        "  } elsif ($main::profile_type eq 'cpu' && !$main::opt_no_auto_signal_frames) {\n"
        "    # Drop signal handlers used for CPU profile collection\n"
        "    # TODO(dpeng): this should not be necessary; it's taken\n"
        "    # care of by the general 2nd-pc mechanism below.\n"
        "    foreach my $name ('ProfileData::Add',           # historical\n"
        "                      'ProfileData::prof_handler',  # historical\n"
        "                      'CpuProfiler::prof_handler',\n"
        "                      '__FRAME_END__',\n"
        "                      '__pthread_sighandler',\n"
        "                      '__restore') {\n"
        "      $skip{$name} = 1;\n"
        "    }\n"
        "  } else {\n"
        "    # Nothing skipped for unknown types\n"
        "  }\n"
        "\n"
        "  if ($main::profile_type eq 'cpu') {\n"
        "    # If all the second-youngest program counters are the same,\n"
        "    # this STRONGLY suggests that it is an artifact of measurement,\n"
        "    # i.e., stack frames pushed by the CPU profiler signal handler.\n"
        "    # Hence, we delete them.\n"
        "    # (The topmost PC is read from the signal structure, not from\n"
        "    # the stack, so it does not get involved.)\n"
        "    while (my $second_pc = IsSecondPcAlwaysTheSame($profile)) {\n"
        "      my $result = {};\n"
        "      my $func = '';\n"
        "      if (exists($symbols->{$second_pc})) {\n"
        "        $second_pc = $symbols->{$second_pc}->[0];\n"
        "      }\n"
        "      if ($main::opt_no_auto_signal_frames) {\n"
        "        print STDERR \"All second stack frames are same: `$second_pc'.\\nMight be "
        "stack trace capturing bug.\\n\";\n"
        "        last;\n"
        "      }\n"
        "      print STDERR \"Removing $second_pc from all stack traces.\\n\";\n"
        "      foreach my $k (keys(%{$profile})) {\n"
        "        my $count = $profile->{$k};\n"
        "        my @addrs = split(/\\n/, $k);\n"
        "        my $topaddr = POSIX::strtoul($addrs[0], 16);\n"
        "        splice @addrs, 1, 1;\n"
        "        if ($#addrs > 1) {\n"
        "          my $subtopaddr = POSIX::strtoul($addrs[1], 16);\n"
        "          if ($subtopaddr + 1 == $topaddr) {\n"
        "            splice @addrs, 1, 1;\n"
        "          }\n"
        "        }\n"
        "        my $reduced_path = join(\"\\n\", @addrs);\n"
        "        AddEntry($result, $reduced_path, $count);\n"
        "      }\n"
        "      $profile = $result;\n"
        "    }\n"
        "  }\n"
        "\n"
        "  my $result = {};\n"
        "  foreach my $k (keys(%{$profile})) {\n"
        "    my $count = $profile->{$k};\n"
        "    my @addrs = split(/\\n/, $k);\n"
        "    my @path = ();\n"
        "    foreach my $a (@addrs) {\n"
        "      if (exists($symbols->{$a})) {\n"
        "        my $func = $symbols->{$a}->[0];\n"
        "        if ($skip{$func} || ($func =~ m/$skip_regexp/)) {\n"
        "          next;\n"
        "        }\n"
        "      }\n"
        "      push(@path, $a);\n"
        "    }\n"
        "    my $reduced_path = join(\"\\n\", @path);\n"
        "    AddEntry($result, $reduced_path, $count);\n"
        "  }\n"
        "  return $result;\n"
        "}\n"
        "\n"
        "# Reduce profile to granularity given by user\n"
        "sub ReduceProfile {\n"
        "  my $symbols = shift;\n"
        "  my $profile = shift;\n"
        "  my $result = {};\n"
        "  my $fullname_to_shortname_map = {};\n"
        "  FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map);\n"
        "  foreach my $k (keys(%{$profile})) {\n"
        "    my $count = $profile->{$k};\n"
        "    my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k);\n"
        "    my @path = ();\n"
        "    my %seen = ();\n"
        "    $seen{''} = 1;      # So that empty keys are skipped\n"
        "    foreach my $e (@translated) {\n"
        "      # To avoid double-counting due to recursion, skip a stack-trace\n"
        "      # entry if it has already been seen\n"
        "      if (!$seen{$e}) {\n"
        "        $seen{$e} = 1;\n"
        "        push(@path, $e);\n"
        "      }\n"
        "    }\n"
        "    my $reduced_path = join(\"\\n\", @path);\n"
        "    AddEntry($result, $reduced_path, $count);\n"
        "  }\n"
        "  return $result;\n"
        "}\n"
        "\n"
        "# Does the specified symbol array match the regexp?\n"
        "sub SymbolMatches {\n"
        "  my $sym = shift;\n"
        "  my $re = shift;\n"
        "  if (defined($sym)) {\n"
        "    for (my $i = 0; $i < $#{$sym}; $i += 3) {\n"
        "      if ($sym->[$i] =~ m/$re/ || $sym->[$i+1] =~ m/$re/) {\n"
        "        return 1;\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "  return 0;\n"
        "}\n"
        "\n"
        "# Focus only on paths involving specified regexps\n"
        "sub FocusProfile {\n"
        "  my $symbols = shift;\n"
        "  my $profile = shift;\n"
        "  my $focus = shift;\n"
        "  my $result = {};\n"
        "  foreach my $k (keys(%{$profile})) {\n"
        "    my $count = $profile->{$k};\n"
        "    my @addrs = split(/\\n/, $k);\n"
        "    foreach my $a (@addrs) {\n"
        "      # Reply if it matches either the address/shortname/fileline\n"
        "      if (($a =~ m/$focus/) || SymbolMatches($symbols->{$a}, $focus)) {\n"
        "        AddEntry($result, $k, $count);\n"
        "        last;\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "  return $result;\n"
        "}\n"
        "\n"
        "# Focus only on paths not involving specified regexps\n"
        "sub IgnoreProfile {\n"
        "  my $symbols = shift;\n"
        "  my $profile = shift;\n"
        "  my $ignore = shift;\n"
        "  my $result = {};\n"
        "  foreach my $k (keys(%{$profile})) {\n"
        "    my $count = $profile->{$k};\n"
        "    my @addrs = split(/\\n/, $k);\n"
        "    my $matched = 0;\n"
        "    foreach my $a (@addrs) {\n"
        "      # Reply if it matches either the address/shortname/fileline\n"
        "      if (($a =~ m/$ignore/) || SymbolMatches($symbols->{$a}, $ignore)) {\n"
        "        $matched = 1;\n"
        "        last;\n"
        "      }\n"
        "    }\n"
        "    if (!$matched) {\n"
        "      AddEntry($result, $k, $count);\n"
        "    }\n"
        "  }\n"
        "  return $result;\n"
        "}\n"
        "\n"
        "# Get total count in profile\n"
        "sub TotalProfile {\n"
        "  my $profile = shift;\n"
        "  my $result = 0;\n"
        "  foreach my $k (keys(%{$profile})) {\n"
        "    $result += $profile->{$k};\n"
        "  }\n"
        "  return $result;\n"
        "}\n"
        "\n"
        "# Add A to B\n"
        "sub AddProfile {\n"
        "  my $A = shift;\n"
        "  my $B = shift;\n"
        "\n"
        "  my $R = {};\n"
        "  # add all keys in A\n"
        "  foreach my $k (keys(%{$A})) {\n"
        "    my $v = $A->{$k};\n"
        "    AddEntry($R, $k, $v);\n"
        "  }\n"
        "  # add all keys in B\n"
        "  foreach my $k (keys(%{$B})) {\n"
        "    my $v = $B->{$k};\n"
        "    AddEntry($R, $k, $v);\n"
        "  }\n"
        "  return $R;\n"
        "}\n"
        "\n"
        "# Merges symbol maps\n"
        "sub MergeSymbols {\n"
        "  my $A = shift;\n"
        "  my $B = shift;\n"
        "\n"
        "  my $R = {};\n"
        "  foreach my $k (keys(%{$A})) {\n"
        "    $R->{$k} = $A->{$k};\n"
        "  }\n"
        "  if (defined($B)) {\n"
        "    foreach my $k (keys(%{$B})) {\n"
        "      $R->{$k} = $B->{$k};\n"
        "    }\n"
        "  }\n"
        "  return $R;\n"
        "}\n"
        "\n"
        "\n"
        "# Add A to B\n"
        "sub AddPcs {\n"
        "  my $A = shift;\n"
        "  my $B = shift;\n"
        "\n"
        "  my $R = {};\n"
        "  # add all keys in A\n"
        "  foreach my $k (keys(%{$A})) {\n"
        "    $R->{$k} = 1\n"
        "  }\n"
        "  # add all keys in B\n"
        "  foreach my $k (keys(%{$B})) {\n"
        "    $R->{$k} = 1\n"
        "  }\n"
        "  return $R;\n"
        "}\n"
        "\n"
        "# Subtract B from A\n"
        "sub SubtractProfile {\n"
        "  my $A = shift;\n"
        "  my $B = shift;\n"
        "\n"
        "  my $R = {};\n"
        "  foreach my $k (keys(%{$A})) {\n"
        "    my $v = $A->{$k} - GetEntry($B, $k);\n"
        "    if ($v < 0 && $main::opt_drop_negative) {\n"
        "      $v = 0;\n"
        "    }\n"
        "    AddEntry($R, $k, $v);\n"
        "  }\n"
        "  if (!$main::opt_drop_negative) {\n"
        "    # Take care of when subtracted profile has more entries\n"
        "    foreach my $k (keys(%{$B})) {\n"
        "      if (!exists($A->{$k})) {\n"
        "        AddEntry($R, $k, 0 - $B->{$k});\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "  return $R;\n"
        "}\n"
        "\n"
        "# Get entry from profile; zero if not present\n"
        "sub GetEntry {\n"
        "  my $profile = shift;\n"
        "  my $k = shift;\n"
        "  if (exists($profile->{$k})) {\n"
        "    return $profile->{$k};\n"
        "  } else {\n"
        "    return 0;\n"
        "  }\n"
        "}\n"
        "\n"
        "# Add entry to specified profile\n"
        "sub AddEntry {\n"
        "  my $profile = shift;\n"
        "  my $k = shift;\n"
        "  my $n = shift;\n"
        "  if (!exists($profile->{$k})) {\n"
        "    $profile->{$k} = 0;\n"
        "  }\n"
        "  $profile->{$k} += $n;\n"
        "}\n"
        "\n"
        "# Add a stack of entries to specified profile, and add them to the $pcs\n"
        "# list.\n"
        "sub AddEntries {\n"
        "  my $profile = shift;\n"
        "  my $pcs = shift;\n"
        "  my $stack = shift;\n"
        "  my $count = shift;\n"
        "  my @k = ();\n"
        "\n"
        "  foreach my $e (split(/\\s+/, $stack)) {\n"
        "    my $pc = HexExtend($e);\n"
        "    $pcs->{$pc} = 1;\n"
        "    push @k, $pc;\n"
        "  }\n"
        "  AddEntry($profile, (join \"\\n\", @k), $count);\n"
        "}\n"
        "\n"
        "##### Code to profile a server dynamically #####\n"
        "\n"
        "sub CheckSymbolPage {\n"
        "  my $url = SymbolPageURL();\n"
        "  my $command = ShellEscape(@URL_FETCHER, $url);\n"
        "  open(SYMBOL, \"$command |\") or error($command);\n"
        "  my $line = <SYMBOL>;\n"
        "  $line =~ s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "  close(SYMBOL);\n"
        "  unless (defined($line)) {\n"
        "    error(\"$url doesn't exist\\n\");\n"
        "  }\n"
        "\n"
        "  if ($line =~ /^num_symbols:\\s+(\\d+)$/) {\n"
        "    if ($1 == 0) {\n"
        "      error(\"Stripped binary. No symbols available.\\n\");\n"
        "    }\n"
        "  } else {\n"
        "    error(\"Failed to get the number of symbols from $url\\n\");\n"
        "  }\n"
        "}\n"
        "\n"
        "sub IsProfileURL {\n"
        "  my $profile_name = shift;\n"
        "  if (-f $profile_name) {\n"
        "    printf STDERR \"Using local file $profile_name.\\n\";\n"
        "    return 0;\n"
        "  }\n"
        "  return 1;\n"
        "}\n"
        "\n"
        "sub ParseProfileURL {\n"
        "  my $profile_name = shift;\n"
        "\n"
        "  if (!defined($profile_name) || $profile_name eq \"\") {\n"
        "    return ();\n"
        "  }\n"
        "\n"
        "  # Split profile URL - matches all non-empty strings, so no test.\n"
        "  $profile_name =~ m,^(https?://)?([^/]+)(.*?)(/|$PROFILES)?$,;\n"
        "\n"
        "  my $proto = $1 || \"http://\";\n"
        "  my $hostport = $2;\n"
        "  my $prefix = $3;\n"
        "  my $profile = $4 || \"/\";\n"
        "\n"
        "  my $host = $hostport;\n"
        "  $host =~ s/:.*//;\n"
        "\n"
        "  my $baseurl = \"$proto$hostport$prefix\";\n"
        "  return ($host, $baseurl, $profile);\n"
        "}\n"
        "\n"
        "# We fetch symbols from the first profile argument.\n"
        "sub SymbolPageURL {\n"
        "  my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]);\n"
        "  return \"$baseURL$SYMBOL_PAGE\";\n"
        "}\n"
        "\n"
        "sub FetchProgramName() {\n"
        "  my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]);\n"
        "  my $url = \"$baseURL$PROGRAM_NAME_PAGE\";\n"
        "  my $command_line = ShellEscape(@URL_FETCHER, $url);\n"
        "  open(CMDLINE, \"$command_line |\") or error($command_line);\n"
        "  my $cmdline = <CMDLINE>;\n"
        "  $cmdline =~ s/\\r//g;   # turn windows-looking lines into unix-looking lines\n"
        "  close(CMDLINE);\n"
        "  error(\"Failed to get program name from $url\\n\") unless defined($cmdline);\n"
        "  $cmdline =~ s/\\x00.+//;  # Remove argv[1] and latters.\n"
        "  $cmdline =~ s!\\n!!g;  # Remove LFs.\n"
        "  return $cmdline;\n"
        "}\n"
        "\n"
        "# Gee, curl's -L (--location) option isn't reliable at least\n"
        "# with its 7.12.3 version.  Curl will forget to post data if\n"
        "# there is a redirection.  This function is a workaround for\n"
        "# curl.  Redirection happens on borg hosts.\n"
        "sub ResolveRedirectionForCurl {\n"
        "  my $url = shift;\n"
        "  my $command_line = ShellEscape(@URL_FETCHER, \"--head\", $url);\n"
        "  open(CMDLINE, \"$command_line |\") or error($command_line);\n"
        "  while (<CMDLINE>) {\n"
        "    s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "    if (/^Location: (.*)/) {\n"
        "      $url = $1;\n"
        "    }\n"
        "  }\n"
        "  close(CMDLINE);\n"
        "  return $url;\n"
        "}\n"
        "\n"
        "# Add a timeout flat to URL_FETCHER.  Returns a new list.\n"
        "sub AddFetchTimeout {\n"
        "  my $timeout = shift;\n"
        "  my @fetcher = @_;\n"
        "  if (defined($timeout)) {\n"
        "    if (join(\" \", @fetcher) =~ m/\\bcurl -s/) {\n"
        "      push(@fetcher, \"--max-time\", sprintf(\"%d\", $timeout));\n"
        "    } elsif (join(\" \", @fetcher) =~ m/\\brpcget\\b/) {\n"
        "      push(@fetcher, sprintf(\"--deadline=%d\", $timeout));\n"
        "    }\n"
        "  }\n"
        "  return @fetcher;\n"
        "}\n"
        "\n"
        "# Reads a symbol map from the file handle name given as $1, returning\n"
        "# the resulting symbol map.  Also processes variables relating to symbols.\n"
        "# Currently, the only variable processed is 'binary=<value>' which updates\n"
        "# $main::prog to have the correct program name.\n"
        "sub ReadSymbols {\n"
        "  my $in = shift;\n"
        "  my $map = {};\n"
        "  while (<$in>) {\n"
        "    s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "    # Removes all the leading zeroes from the symbols, see comment below.\n"
        "    if (m/^0x0*([0-9a-f]+)\\s+(.+)/) {\n"
        "      $map->{$1} = $2;\n"
        "    } elsif (m/^---/) {\n"
        "      last;\n"
        "    } elsif (m/^([a-z][^=]*)=(.*)$/ ) {\n"
        "      my ($variable, $value) = ($1, $2);\n"
        "      for ($variable, $value) {\n"
        "        s/^\\s+//;\n"
        "        s/\\s+$//;\n"
        "      }\n"
        "      if ($variable eq \"binary\") {\n"
        "        if ($main::prog ne $UNKNOWN_BINARY && $main::prog ne $value) {\n"
        "          printf STDERR (\"Warning: Mismatched binary name '%s', using '%s'.\\n\",\n"
        "                         $main::prog, $value);\n"
        "        }\n"
        "        $main::prog = $value;\n"
        "      } else {\n"
        "        printf STDERR (\"Ignoring unknown variable in symbols list: \" .\n"
        "            \"'%s' = '%s'\\n\", $variable, $value);\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "  return $map;\n"
        "}\n"
        "\n"
        "# Fetches and processes symbols to prepare them for use in the profile output\n"
        "# code.  If the optional 'symbol_map' arg is not given, fetches symbols from\n"
        "# $SYMBOL_PAGE for all PC values found in profile.  Otherwise, the raw symbols\n"
        "# are assumed to have already been fetched into 'symbol_map' and are simply\n"
        "# extracted and processed.\n"
        "sub FetchSymbols {\n"
        "  my $pcset = shift;\n"
        "  my $symbol_map = shift;\n"
        "\n"
        "  my %seen = ();\n"
        "  my @pcs = grep { !$seen{$_}++ } keys(%$pcset);  # uniq\n"
        "\n"
        "  if (!defined($symbol_map)) {\n"
        "    my $post_data = join(\"+\", sort((map {\"0x\" . \"$_\"} @pcs)));\n"
        "\n"
        "    open(POSTFILE, \">$main::tmpfile_sym\");\n"
        "    print POSTFILE $post_data;\n"
        "    close(POSTFILE);\n"
        "\n"
        "    my $url = SymbolPageURL();\n"
        "\n"
        "    my $command_line;\n"
        "    if (join(\" \", @URL_FETCHER) =~ m/\\bcurl -s/) {\n"
        "      $url = ResolveRedirectionForCurl($url);\n"
        "      $command_line = ShellEscape(@URL_FETCHER, \"-d\", \"\\@$main::tmpfile_sym\",\n"
        "                                  $url);\n"
        "    } else {\n"
        "      $command_line = (ShellEscape(@URL_FETCHER, \"--post\", $url)\n"
        "                       . \" < \" . ShellEscape($main::tmpfile_sym));\n"
        "    }\n"
        "    # We use c++filt in case $SYMBOL_PAGE gives us mangled symbols.\n"
        "    my $escaped_cppfilt = ShellEscape($obj_tool_map{\"c++filt\"});\n"
        "    open(SYMBOL, \"$command_line | $escaped_cppfilt |\") or error($command_line);\n"
        "    $symbol_map = ReadSymbols(*SYMBOL{IO});\n"
        "    close(SYMBOL);\n"
        "  }\n"
        "\n"
        "  my $symbols = {};\n"
        "  foreach my $pc (@pcs) {\n"
        "    my $fullname;\n"
        "    # For 64 bits binaries, symbols are extracted with 8 leading zeroes.\n"
        "    # Then /symbol reads the long symbols in as uint64, and outputs\n"
        "    # the result with a \"0x%08llx\" format which get rid of the zeroes.\n"
        "    # By removing all the leading zeroes in both $pc and the symbols from\n"
        "    # /symbol, the symbols match and are retrievable from the map.\n"
        "    my $shortpc = $pc;\n"
        "    $shortpc =~ s/^0*//;\n"
        "    # Each line may have a list of names, which includes the function\n"
        "    # and also other functions it has inlined.  They are separated (in\n"
        "    # PrintSymbolizedProfile), by --, which is illegal in function names.\n"
        "    my $fullnames;\n"
        "    if (defined($symbol_map->{$shortpc})) {\n"
        "      $fullnames = $symbol_map->{$shortpc};\n"
        "    } else {\n"
        "      $fullnames = \"0x\" . $pc;  # Just use addresses\n"
        "    }\n"
        "    my $sym = [];\n"
        "    $symbols->{$pc} = $sym;\n"
        "    foreach my $fullname (split(\"--\", $fullnames)) {\n"
        "      my $name = ShortFunctionName($fullname);\n"
        "      push(@{$sym}, $name, \"?\", $fullname);\n"
        "    }\n"
        "  }\n"
        "  return $symbols;\n"
        "}\n"
        "\n"
        "sub BaseName {\n"
        "  my $file_name = shift;\n"
        "  $file_name =~ s!^.*/!!;  # Remove directory name\n"
        "  return $file_name;\n"
        "}\n"
        "\n"
        "sub MakeProfileBaseName {\n"
        "  my ($binary_name, $profile_name) = @_;\n"
        "  my ($host, $baseURL, $path) = ParseProfileURL($profile_name);\n"
        "  my $binary_shortname = BaseName($binary_name);\n"
        "  return sprintf(\"%s.%s.%s\",\n"
        "                 $binary_shortname, $main::op_time, $host);\n"
        "}\n"
        "\n"
        "sub FetchDynamicProfile {\n"
        "  my $binary_name = shift;\n"
        "  my $profile_name = shift;\n"
        "  my $fetch_name_only = shift;\n"
        "  my $encourage_patience = shift;\n"
        "\n"
        "  if (!IsProfileURL($profile_name)) {\n"
        "    return $profile_name;\n"
        "  } else {\n"
        "    my ($host, $baseURL, $path) = ParseProfileURL($profile_name);\n"
        "    if ($path eq \"\" || $path eq \"/\") {\n"
        "      # Missing type specifier defaults to cpu-profile\n"
        "      $path = $PROFILE_PAGE;\n"
        "    }\n"
        "\n"
        "    my $profile_file = MakeProfileBaseName($binary_name, $profile_name);\n"
        "\n"
        "    my $url = \"$baseURL$path\";\n"
        "    my $fetch_timeout = undef;\n"
        "    if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE/) {\n"
        "      if ($path =~ m/[?]/) {\n"
        "        $url .= \"&\";\n"
        "      } else {\n"
        "        $url .= \"?\";\n"
        "      }\n"
        "      $url .= sprintf(\"seconds=%d\", $main::opt_seconds);\n"
        "      $fetch_timeout = $main::opt_seconds * 1.01 + 60;\n"
        "    } else {\n"
        "      # For non-CPU profiles, we add a type-extension to\n"
        "      # the target profile file name.\n"
        "      my $suffix = $path;\n"
        "      $suffix =~ s,/,.,g;\n"
        "      $profile_file .= $suffix;\n"
        "    }\n"
        "\n"
        "    my $profile_dir = $ENV{\"PPROF_TMPDIR\"} || ($ENV{HOME} . \"/pprof\");\n"
        "    if (! -d $profile_dir) {\n"
        "      mkdir($profile_dir)\n"
        "          || die(\"Unable to create profile directory $profile_dir: $!\\n\");\n"
        "    }\n"
        "    my $tmp_profile = \"$profile_dir/.tmp.$profile_file\";\n"
        "    my $real_profile = \"$profile_dir/$profile_file\";\n"
        "\n"
        "    if ($fetch_name_only > 0) {\n"
        "      return $real_profile;\n"
        "    }\n"
        "\n"
        "    my @fetcher = AddFetchTimeout($fetch_timeout, @URL_FETCHER);\n"
        "    my $cmd = ShellEscape(@fetcher, $url) . \" > \" . ShellEscape($tmp_profile);\n"
        "    if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE|$CENSUSPROFILE_PAGE/){\n"
        "      print STDERR \"Gathering CPU profile from $url for $main::opt_seconds seconds "
        "to\\n  ${real_profile}\\n\";\n"
        "      if ($encourage_patience) {\n"
        "        print STDERR \"Be patient...\\n\";\n"
        "      }\n"
        "    } else {\n"
        "      print STDERR \"Fetching $path profile from $url to\\n  ${real_profile}\\n\";\n"
        "    }\n"
        "\n"
        "    (system($cmd) == 0) || error(\"Failed to get profile: $cmd: $!\\n\");\n"
        "    (system(\"mv\", $tmp_profile, $real_profile) == 0) || error(\"Unable to rename "
        "profile\\n\");\n"
        "    print STDERR \"Wrote profile to $real_profile\\n\";\n"
        "    $main::collected_profile = $real_profile;\n"
        "    return $main::collected_profile;\n"
        "  }\n"
        "}\n"
        "\n"
        "# Collect profiles in parallel\n"
        "sub FetchDynamicProfiles {\n"
        "  my $items = scalar(@main::pfile_args);\n"
        "  my $levels = log($items) / log(2);\n"
        "\n"
        "  if ($items == 1) {\n"
        "    $main::profile_files[0] = FetchDynamicProfile($main::prog, $main::pfile_args[0], "
        "0, 1);\n"
        "  } else {\n"
        "    # math rounding issues\n"
        "    if ((2 ** $levels) < $items) {\n"
        "     $levels++;\n"
        "    }\n"
        "    my $count = scalar(@main::pfile_args);\n"
        "    for (my $i = 0; $i < $count; $i++) {\n"
        "      $main::profile_files[$i] = FetchDynamicProfile($main::prog, "
        "$main::pfile_args[$i], 1, 0);\n"
        "    }\n"
        "    print STDERR \"Fetching $count profiles, Be patient...\\n\";\n"
        "    FetchDynamicProfilesRecurse($levels, 0, 0);\n"
        "    $main::collected_profile = join(\" \\\\\\n    \", @main::profile_files);\n"
        "  }\n"
        "}\n"
        "\n"
        "# Recursively fork a process to get enough processes\n"
        "# collecting profiles\n"
        "sub FetchDynamicProfilesRecurse {\n"
        "  my $maxlevel = shift;\n"
        "  my $level = shift;\n"
        "  my $position = shift;\n"
        "\n"
        "  if (my $pid = fork()) {\n"
        "    $position = 0 | ($position << 1);\n"
        "    TryCollectProfile($maxlevel, $level, $position);\n"
        "    wait;\n"
        "  } else {\n"
        "    $position = 1 | ($position << 1);\n"
        "    TryCollectProfile($maxlevel, $level, $position);\n"
        "    cleanup();\n"
        "    exit(0);\n"
        "  }\n"
        "}\n"
        "\n"
        "# Collect a single profile\n"
        "sub TryCollectProfile {\n"
        "  my $maxlevel = shift;\n"
        "  my $level = shift;\n"
        "  my $position = shift;\n"
        "\n"
        "  if ($level >= ($maxlevel - 1)) {\n"
        "    if ($position < scalar(@main::pfile_args)) {\n"
        "      FetchDynamicProfile($main::prog, $main::pfile_args[$position], 0, 0);\n"
        "    }\n"
        "  } else {\n"
        "    FetchDynamicProfilesRecurse($maxlevel, $level+1, $position);\n"
        "  }\n"
        "}\n"
        "\n"
        "##### Parsing code #####\n"
        "\n"
        "# Provide a small streaming-read module to handle very large\n"
        "# cpu-profile files.  Stream in chunks along a sliding window.\n"
        "# Provides an interface to get one 'slot', correctly handling\n"
        "# endian-ness differences.  A slot is one 32-bit or 64-bit word\n"
        "# (depending on the input profile).  We tell endianness and bit-size\n"
        "# for the profile by looking at the first 8 bytes: in cpu profiles,\n"
        "# the second slot is always 3 (we'll accept anything that's not 0).\n"
        "BEGIN {\n"
        "  package CpuProfileStream;\n"
        "\n"
        "  sub new {\n"
        "    my ($class, $file, $fname) = @_;\n"
        "    my $self = { file        => $file,\n"
        "                 base        => 0,\n"
        "                 stride      => 512 * 1024,   # must be a multiple of bitsize/8\n"
        "                 slots       => [],\n"
        "                 unpack_code => \"\",           # N for big-endian, V for little\n"
        "                 perl_is_64bit => 1,          # matters if profile is 64-bit\n"
        "    };\n"
        "    bless $self, $class;\n"
        "    # Let unittests adjust the stride\n"
        "    if ($main::opt_test_stride > 0) {\n"
        "      $self->{stride} = $main::opt_test_stride;\n"
        "    }\n"
        "    # Read the first two slots to figure out bitsize and endianness.\n"
        "    my $slots = $self->{slots};\n"
        "    my $str;\n"
        "    read($self->{file}, $str, 8);\n"
        "    # Set the global $address_length based on what we see here.\n"
        "    # 8 is 32-bit (8 hexadecimal chars); 16 is 64-bit (16 hexadecimal chars).\n"
        "    $address_length = ($str eq (chr(0)x8)) ? 16 : 8;\n"
        "    if ($address_length == 8) {\n"
        "      if (substr($str, 6, 2) eq chr(0)x2) {\n"
        "        $self->{unpack_code} = 'V';  # Little-endian.\n"
        "      } elsif (substr($str, 4, 2) eq chr(0)x2) {\n"
        "        $self->{unpack_code} = 'N';  # Big-endian\n"
        "      } else {\n"
        "        ::error(\"$fname: header size >= 2**16\\n\");\n"
        "      }\n"
        "      @$slots = unpack($self->{unpack_code} . \"*\", $str);\n"
        "    } else {\n"
        "      # If we're a 64-bit profile, check if we're a 64-bit-capable\n"
        "      # perl.  Otherwise, each slot will be represented as a float\n"
        "      # instead of an int64, losing precision and making all the\n"
        "      # 64-bit addresses wrong.  We won't complain yet, but will\n"
        "      # later if we ever see a value that doesn't fit in 32 bits.\n"
        "      my $has_q = 0;\n"
        "      eval { $has_q = pack(\"Q\", \"1\") ? 1 : 1; };\n"
        "      if (!$has_q) {\n"
        "        $self->{perl_is_64bit} = 0;\n"
        "      }\n"
        "      read($self->{file}, $str, 8);\n"
        "      if (substr($str, 4, 4) eq chr(0)x4) {\n"
        "        # We'd love to use 'Q', but it's a) not universal, b) not endian-proof.\n"
        "        $self->{unpack_code} = 'V';  # Little-endian.\n"
        "      } elsif (substr($str, 0, 4) eq chr(0)x4) {\n"
        "        $self->{unpack_code} = 'N';  # Big-endian\n"
        "      } else {\n"
        "        ::error(\"$fname: header size >= 2**32\\n\");\n"
        "      }\n"
        "      my @pair = unpack($self->{unpack_code} . \"*\", $str);\n"
        "      # Since we know one of the pair is 0, it's fine to just add them.\n"
        "      @$slots = (0, $pair[0] + $pair[1]);\n"
        "    }\n"
        "    return $self;\n"
        "  }\n"
        "\n"
        "  # Load more data when we access slots->get(X) which is not yet in memory.\n"
        "  sub overflow {\n"
        "    my ($self) = @_;\n"
        "    my $slots = $self->{slots};\n"
        "    $self->{base} += $#$slots + 1;   # skip over data we're replacing\n"
        "    my $str;\n"
        "    read($self->{file}, $str, $self->{stride});\n"
        "    if ($address_length == 8) {      # the 32-bit case\n"
        "      # This is the easy case: unpack provides 32-bit unpacking primitives.\n"
        "      @$slots = unpack($self->{unpack_code} . \"*\", $str);\n"
        "    } else {\n"
        "      # We need to unpack 32 bits at a time and combine.\n"
        "      my @b32_values = unpack($self->{unpack_code} . \"*\", $str);\n"
        "      my @b64_values = ();\n"
        "      for (my $i = 0; $i < $#b32_values; $i += 2) {\n"
        "        # TODO(csilvers): if this is a 32-bit perl, the math below\n"
        "        #    could end up in a too-large int, which perl will promote\n"
        "        #    to a double, losing necessary precision.  Deal with that.\n"
        "        #    Right now, we just die.\n"
        "        my ($lo, $hi) = ($b32_values[$i], $b32_values[$i+1]);\n"
        "        if ($self->{unpack_code} eq 'N') {    # big-endian\n"
        "          ($lo, $hi) = ($hi, $lo);\n"
        "        }\n"
        "        my $value = $lo + $hi * (2**32);\n"
        "        if (!$self->{perl_is_64bit} &&   # check value is exactly represented\n"
        "            (($value % (2**32)) != $lo || int($value / (2**32)) != $hi)) {\n"
        "          ::error(\"Need a 64-bit perl to process this 64-bit profile.\\n\");\n"
        "        }\n"
        "        push(@b64_values, $value);\n"
        "      }\n"
        "      @$slots = @b64_values;\n"
        "    }\n"
        "  }\n"
        "\n"
        "  # Access the i-th long in the file (logically), or -1 at EOF.\n"
        "  sub get {\n"
        "    my ($self, $idx) = @_;\n"
        "    my $slots = $self->{slots};\n"
        "    while ($#$slots >= 0) {\n"
        "      if ($idx < $self->{base}) {\n"
        "        # The only time we expect a reference to $slots[$i - something]\n"
        "        # after referencing $slots[$i] is reading the very first header.\n"
        "        # Since $stride > |header|, that shouldn't cause any lookback\n"
        "        # errors.  And everything after the header is sequential.\n"
        "        print STDERR \"Unexpected look-back reading CPU profile\";\n"
        "        return -1;   # shrug, don't know what better to return\n"
        "      } elsif ($idx > $self->{base} + $#$slots) {\n"
        "        $self->overflow();\n"
        "      } else {\n"
        "        return $slots->[$idx - $self->{base}];\n"
        "      }\n"
        "    }\n"
        "    # If we get here, $slots is [], which means we've reached EOF\n"
        "    return -1;  # unique since slots is supposed to hold unsigned numbers\n"
        "  }\n"
        "}\n"
        "\n"
        "# Reads the top, 'header' section of a profile, and returns the last\n"
        "# line of the header, commonly called a 'header line'.  The header\n"
        "# section of a profile consists of zero or more 'command' lines that\n"
        "# are instructions to pprof, which pprof executes when reading the\n"
        "# header.  All 'command' lines start with a %.  After the command\n"
        "# lines is the 'header line', which is a profile-specific line that\n"
        "# indicates what type of profile it is, and perhaps other global\n"
        "# information about the profile.  For instance, here's a header line\n"
        "# for a heap profile:\n"
        "#   heap profile:     53:    38236 [  5525:  1284029] @ heapprofile\n"
        "# For historical reasons, the CPU profile does not contain a text-\n"
        "# readable header line.  If the profile looks like a CPU profile,\n"
        "# this function returns \"\".  If no header line could be found, this\n"
        "# function returns undef.\n"
        "#\n"
        "# The following commands are recognized:\n"
        "#   %warn -- emit the rest of this line to stderr, prefixed by 'WARNING:'\n"
        "#\n"
        "# The input file should be in binmode.\n"
        "sub ReadProfileHeader {\n"
        "  local *PROFILE = shift;\n"
        "  my $firstchar = \"\";\n"
        "  my $line = \"\";\n"
        "  read(PROFILE, $firstchar, 1);\n"
        "  seek(PROFILE, -1, 1);                    # unread the firstchar\n"
        "  if ($firstchar !~ /[[:print:]]/) {       # is not a text character\n"
        "    return \"\";\n"
        "  }\n"
        "  while (defined($line = <PROFILE>)) {\n"
        "    $line =~ s/\\r//g;   # turn windows-looking lines into unix-looking lines\n"
        "    if ($line =~ /^%warn\\s+(.*)/) {        # 'warn' command\n"
        "      # Note this matches both '%warn blah\\n' and '%warn\\n'.\n"
        "      print STDERR \"WARNING: $1\\n\";        # print the rest of the line\n"
        "    } elsif ($line =~ /^%/) {\n"
        "      print STDERR \"Ignoring unknown command from profile header: $line\";\n"
        "    } else {\n"
        "      # End of commands, must be the header line.\n"
        "      return $line;\n"
        "    }\n"
        "  }\n"
        "  return undef;     # got to EOF without seeing a header line\n"
        "}\n"
        "\n"
        "sub IsSymbolizedProfileFile {\n"
        "  my $file_name = shift;\n"
        "  if (!(-e $file_name) || !(-r $file_name)) {\n"
        "    return 0;\n"
        "  }\n"
        "  # Check if the file contains a symbol-section marker.\n"
        "  open(TFILE, \"<$file_name\");\n"
        "  binmode TFILE;\n"
        "  my $firstline = ReadProfileHeader(*TFILE);\n"
        "  close(TFILE);\n"
        "  if (!$firstline) {\n"
        "    return 0;\n"
        "  }\n"
        "  $SYMBOL_PAGE =~ m,[^/]+$,;    # matches everything after the last slash\n"
        "  my $symbol_marker = $&;\n"
        "  return $firstline =~ /^--- *$symbol_marker/;\n"
        "}\n"
        "\n"
        "# Parse profile generated by common/profiler.cc and return a reference\n"
        "# to a map:\n"
        "#      $result->{version}     Version number of profile file\n"
        "#      $result->{period}      Sampling period (in microseconds)\n"
        "#      $result->{profile}     Profile object\n"
        "#      $result->{map}         Memory map info from profile\n"
        "#      $result->{pcs}         Hash of all PC values seen, key is hex address\n"
        "sub ReadProfile {\n"
        "  my $prog = shift;\n"
        "  my $fname = shift;\n"
        "  my $result;            # return value\n"
        "\n"
        "  $CONTENTION_PAGE =~ m,[^/]+$,;    # matches everything after the last slash\n"
        "  my $contention_marker = $&;\n"
        "  $GROWTH_PAGE  =~ m,[^/]+$,;    # matches everything after the last slash\n"
        "  my $growth_marker = $&;\n"
        "  $SYMBOL_PAGE =~ m,[^/]+$,;    # matches everything after the last slash\n"
        "  my $symbol_marker = $&;\n"
        "  $PROFILE_PAGE =~ m,[^/]+$,;    # matches everything after the last slash\n"
        "  my $profile_marker = $&;\n"
        "\n"
        "  # Look at first line to see if it is a heap or a CPU profile.\n"
        "  # CPU profile may start with no header at all, and just binary data\n"
        "  # (starting with \\0\\0\\0\\0) -- in that case, don't try to read the\n"
        "  # whole firstline, since it may be gigabytes(!) of data.\n"
        "  open(PROFILE, \"<$fname\") || error(\"$fname: $!\\n\");\n"
        "  binmode PROFILE;      # New perls do UTF-8 processing\n"
        "  my $header = ReadProfileHeader(*PROFILE);\n"
        "  if (!defined($header)) {   # means \"at EOF\"\n"
        "    error(\"Profile is empty.\\n\");\n"
        "  }\n"
        "\n"
        "  my $symbols;\n"
        "  if ($header =~ m/^--- *$symbol_marker/o) {\n"
        "    # Verify that the user asked for a symbolized profile\n"
        "    if (!$main::use_symbolized_profile) {\n"
        "      # we have both a binary and symbolized profiles, abort\n"
        "      error(\"FATAL ERROR: Symbolized profile\\n   $fname\\ncannot be used with \" .\n"
        "            \"a binary arg. Try again without passing\\n   $prog\\n\");\n"
        "    }\n"
        "    # Read the symbol section of the symbolized profile file.\n"
        "    $symbols = ReadSymbols(*PROFILE{IO});\n"
        "    # Read the next line to get the header for the remaining profile.\n"
        "    $header = ReadProfileHeader(*PROFILE) || \"\";\n"
        "  }\n"
        "\n"
        "  $main::profile_type = '';\n"
        "  if ($header =~ m/^heap profile:.*$growth_marker/o) {\n"
        "    $main::profile_type = 'growth';\n"
        "    $result =  ReadHeapProfile($prog, *PROFILE, $header);\n"
        "  } elsif ($header =~ m/^heap profile:/) {\n"
        "    $main::profile_type = 'heap';\n"
        "    $result =  ReadHeapProfile($prog, *PROFILE, $header);\n"
        "  } elsif ($header =~ m/^--- *$contention_marker/o) {\n"
        "    $main::profile_type = 'contention';\n"
        "    $result = ReadSynchProfile($prog, *PROFILE);\n"
        "  } elsif ($header =~ m/^--- *Stacks:/) {\n"
        "    print STDERR\n"
        "      \"Old format contention profile: mistakenly reports \" .\n"
        "      \"condition variable signals as lock contentions.\\n\";\n"
        "    $main::profile_type = 'contention';\n"
        "    $result = ReadSynchProfile($prog, *PROFILE);\n"
        "  } elsif ($header =~ m/^--- *$profile_marker/) {\n"
        "    # the binary cpu profile data starts immediately after this line\n"
        "    $main::profile_type = 'cpu';\n"
        "    $result = ReadCPUProfile($prog, $fname, *PROFILE);\n"
        "  } else {\n"
        "    if (defined($symbols)) {\n"
        "      # a symbolized profile contains a format we don't recognize, bail out\n"
        "      error(\"$fname: Cannot recognize profile section after symbols.\\n\");\n"
        "    }\n"
        "    # no ascii header present -- must be a CPU profile\n"
        "    $main::profile_type = 'cpu';\n"
        "    $result = ReadCPUProfile($prog, $fname, *PROFILE);\n"
        "  }\n"
        "\n"
        "  close(PROFILE);\n"
        "\n"
        "  # if we got symbols along with the profile, return those as well\n"
        "  if (defined($symbols)) {\n"
        "    $result->{symbols} = $symbols;\n"
        "  }\n"
        "\n"
        "  return $result;\n"
        "}\n"
        "\n"
        "# Subtract one from caller pc so we map back to call instr.\n"
        "# However, don't do this if we're reading a symbolized profile\n"
        "# file, in which case the subtract-one was done when the file\n"
        "# was written.\n"
        "#\n"
        "# We apply the same logic to all readers, though ReadCPUProfile uses an\n"
        "# independent implementation.\n"
        "sub FixCallerAddresses {\n"
        "  my $stack = shift;\n"
        "  if ($main::use_symbolized_profile) {\n"
        "    return $stack;\n"
        "  } else {\n"
        "    $stack =~ /(\\s)/;\n"
        "    my $delimiter = $1;\n"
        "    my @addrs = split(' ', $stack);\n"
        "    my @fixedaddrs;\n"
        "    $#fixedaddrs = $#addrs;\n"
        "    if ($#addrs >= 0) {\n"
        "      $fixedaddrs[0] = $addrs[0];\n"
        "    }\n"
        "    for (my $i = 1; $i <= $#addrs; $i++) {\n"
        "      $fixedaddrs[$i] = AddressSub($addrs[$i], \"0x1\");\n"
        "    }\n"
        "    return join $delimiter, @fixedaddrs;\n"
        "  }\n"
        "}\n"
        "\n"
        "# CPU profile reader\n"
        "sub ReadCPUProfile {\n"
        "  my $prog = shift;\n"
        "  my $fname = shift;       # just used for logging\n"
        "  local *PROFILE = shift;\n"
        "  my $version;\n"
        "  my $period;\n"
        "  my $i;\n"
        "  my $profile = {};\n"
        "  my $pcs = {};\n"
        "\n"
        "  # Parse string into array of slots.\n"
        "  my $slots = CpuProfileStream->new(*PROFILE, $fname);\n"
        "\n"
        "  # Read header.  The current header version is a 5-element structure\n"
        "  # containing:\n"
        "  #   0: header count (always 0)\n"
        "  #   1: header \"words\" (after this one: 3)\n"
        "  #   2: format version (0)\n"
        "  #   3: sampling period (usec)\n"
        "  #   4: unused padding (always 0)\n"
        "  if ($slots->get(0) != 0 ) {\n"
        "    error(\"$fname: not a profile file, or old format profile file\\n\");\n"
        "  }\n"
        "  $i = 2 + $slots->get(1);\n"
        "  $version = $slots->get(2);\n"
        "  $period = $slots->get(3);\n"
        "  # Do some sanity checking on these header values.\n"
        "  if ($version > (2**32) || $period > (2**32) || $i > (2**32) || $i < 5) {\n"
        "    error(\"$fname: not a profile file, or corrupted profile file\\n\");\n"
        "  }\n"
        "\n"
        "  # Parse profile\n"
        "  while ($slots->get($i) != -1) {\n"
        "    my $n = $slots->get($i++);\n"
        "    my $d = $slots->get($i++);\n"
        "    if ($d > (2**16)) {  # TODO(csilvers): what's a reasonable max-stack-depth?\n"
        "      my $addr = sprintf(\"0%o\", $i * ($address_length == 8 ? 4 : 8));\n"
        "      print STDERR \"At index $i (address $addr):\\n\";\n"
        "      error(\"$fname: stack trace depth >= 2**32\\n\");\n"
        "    }\n"
        "    if ($slots->get($i) == 0) {\n"
        "      # End of profile data marker\n"
        "      $i += $d;\n"
        "      last;\n"
        "    }\n"
        "\n"
        "    # Make key out of the stack entries\n"
        "    my @k = ();\n"
        "    for (my $j = 0; $j < $d; $j++) {\n"
        "      my $pc = $slots->get($i+$j);\n"
        "      # Subtract one from caller pc so we map back to call instr.\n"
        "      # However, don't do this if we're reading a symbolized profile\n"
        "      # file, in which case the subtract-one was done when the file\n"
        "      # was written.\n"
        "      if ($j > 0 && !$main::use_symbolized_profile) {\n"
        "        $pc--;\n"
        "      }\n"
        "      $pc = sprintf(\"%0*x\", $address_length, $pc);\n"
        "      $pcs->{$pc} = 1;\n"
        "      push @k, $pc;\n"
        "    }\n"
        "\n"
        "    AddEntry($profile, (join \"\\n\", @k), $n);\n"
        "    $i += $d;\n"
        "  }\n"
        "\n"
        "  # Parse map\n"
        "  my $map = '';\n"
        "  seek(PROFILE, $i * ($address_length / 2), 0);\n"
        "  read(PROFILE, $map, (stat PROFILE)[7]);\n"
        "\n"
        "  my $r = {};\n"
        "  $r->{version} = $version;\n"
        "  $r->{period} = $period;\n"
        "  $r->{profile} = $profile;\n"
        "  $r->{libs} = ParseLibraries($prog, $map, $pcs);\n"
        "  $r->{pcs} = $pcs;\n"
        "\n"
        "  return $r;\n"
        "}\n"
        "\n"
        "sub ReadHeapProfile {\n"
        "  my $prog = shift;\n"
        "  local *PROFILE = shift;\n"
        "  my $header = shift;\n"
        "\n"
        "  my $index = 1;\n"
        "  if ($main::opt_inuse_space) {\n"
        "    $index = 1;\n"
        "  } elsif ($main::opt_inuse_objects) {\n"
        "    $index = 0;\n"
        "  } elsif ($main::opt_alloc_space) {\n"
        "    $index = 3;\n"
        "  } elsif ($main::opt_alloc_objects) {\n"
        "    $index = 2;\n"
        "  }\n"
        "\n"
        "  # Find the type of this profile.  The header line looks like:\n"
        "  #    heap profile:   1246:  8800744 [  1246:  8800744] @ <heap-url>/266053\n"
        "  # There are two pairs <count: size>, the first inuse objects/space, and the\n"
        "  # second allocated objects/space.  This is followed optionally by a profile\n"
        "  # type, and if that is present, optionally by a sampling frequency.\n"
        "  # For remote heap profiles (v1):\n"
        "  # The interpretation of the sampling frequency is that the profiler, for\n"
        "  # each sample, calculates a uniformly distributed random integer less than\n"
        "  # the given value, and records the next sample after that many bytes have\n"
        "  # been allocated.  Therefore, the expected sample interval is half of the\n"
        "  # given frequency.  By default, if not specified, the expected sample\n"
        "  # interval is 128KB.  Only remote-heap-page profiles are adjusted for\n"
        "  # sample size.\n"
        "  # For remote heap profiles (v2):\n"
        "  # The sampling frequency is the rate of a Poisson process. This means that\n"
        "  # the probability of sampling an allocation of size X with sampling rate Y\n"
        "  # is 1 - exp(-X/Y)\n"
        "  # For version 2, a typical header line might look like this:\n"
        "  # heap profile:   1922: 127792360 [  1922: 127792360] @ <heap-url>_v2/524288\n"
        "  # the trailing number (524288) is the sampling rate. (Version 1 showed\n"
        "  # double the 'rate' here)\n"
        "  my $sampling_algorithm = 0;\n"
        "  my $sample_adjustment = 0;\n"
        "  chomp($header);\n"
        "  my $type = \"unknown\";\n"
        "  if ($header =~ m\"^heap "
        "profile:\\s*(\\d+):\\s+(\\d+)\\s+\\[\\s*(\\d+):\\s+(\\d+)\\](\\s*@\\s*([^/]*)(/"
        "(\\d+))?)?\") {\n"
        "    if (defined($6) && ($6 ne '')) {\n"
        "      $type = $6;\n"
        "      my $sample_period = $8;\n"
        "      # $type is \"heapprofile\" for profiles generated by the\n"
        "      # heap-profiler, and either \"heap\" or \"heap_v2\" for profiles\n"
        "      # generated by sampling directly within tcmalloc.  It can also\n"
        "      # be \"growth\" for heap-growth profiles.  The first is typically\n"
        "      # found for profiles generated locally, and the others for\n"
        "      # remote profiles.\n"
        "      if (($type eq \"heapprofile\") || ($type !~ /heap/) ) {\n"
        "        # No need to adjust for the sampling rate with heap-profiler-derived data\n"
        "        $sampling_algorithm = 0;\n"
        "      } elsif ($type =~ /_v2/) {\n"
        "        $sampling_algorithm = 2;     # version 2 sampling\n"
        "        if (defined($sample_period) && ($sample_period ne '')) {\n"
        "          $sample_adjustment = int($sample_period);\n"
        "        }\n"
        "      } else {\n"
        "        $sampling_algorithm = 1;     # version 1 sampling\n"
        "        if (defined($sample_period) && ($sample_period ne '')) {\n"
        "          $sample_adjustment = int($sample_period)/2;\n"
        "        }\n"
        "      }\n"
        "    } else {\n"
        "      # We detect whether or not this is a remote-heap profile by checking\n"
        "      # that the total-allocated stats ($n2,$s2) are exactly the\n"
        "      # same as the in-use stats ($n1,$s1).  It is remotely conceivable\n"
        "      # that a non-remote-heap profile may pass this check, but it is hard\n"
        "      # to imagine how that could happen.\n"
        "      # In this case it's so old it's guaranteed to be remote-heap version 1.\n"
        "      my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);\n"
        "      if (($n1 == $n2) && ($s1 == $s2)) {\n"
        "        # This is likely to be a remote-heap based sample profile\n"
        "        $sampling_algorithm = 1;\n"
        "      }\n"
        "    }\n"
        "  }\n"
        "\n"
        "  if ($sampling_algorithm > 0) {\n"
        "    # For remote-heap generated profiles, adjust the counts and sizes to\n"
        "    # account for the sample rate (we sample once every 128KB by default).\n"
        "    if ($sample_adjustment == 0) {\n"
        "      # Turn on profile adjustment.\n"
        "      $sample_adjustment = 128*1024;\n"
        "      print STDERR \"Adjusting heap profiles for 1-in-128KB sampling rate\\n\";\n"
        "    } else {\n"
        "      printf STDERR (\"Adjusting heap profiles for 1-in-%d sampling rate\\n\",\n"
        "                     $sample_adjustment);\n"
        "    }\n"
        "    if ($sampling_algorithm > 1) {\n"
        "      # We don't bother printing anything for the original version (version 1)\n"
        "      printf STDERR \"Heap version $sampling_algorithm\\n\";\n"
        "    }\n"
        "  }\n"
        "\n"
        "  my $profile = {};\n"
        "  my $pcs = {};\n"
        "  my $map = \"\";\n"
        "\n"
        "  while (<PROFILE>) {\n"
        "    s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "    if (/^MAPPED_LIBRARIES:/) {\n"
        "      # Read the /proc/self/maps data\n"
        "      while (<PROFILE>) {\n"
        "        s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "        $map .= $_;\n"
        "      }\n"
        "      last;\n"
        "    }\n"
        "\n"
        "    if (/^--- Memory map:/) {\n"
        "      # Read /proc/self/maps data as formatted by DumpAddressMap()\n"
        "      my $buildvar = \"\";\n"
        "      while (<PROFILE>) {\n"
        "        s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "        # Parse \"build=<dir>\" specification if supplied\n"
        "        if (m/^\\s*build=(.*)\\n/) {\n"
        "          $buildvar = $1;\n"
        "        }\n"
        "\n"
        "        # Expand \"$build\" variable if available\n"
        "        $_ =~ s/\\$build\\b/$buildvar/g;\n"
        "\n"
        "        $map .= $_;\n"
        "      }\n"
        "      last;\n"
        "    }\n"
        "\n"
        "    # Read entry of the form:\n"
        "    #  <count1>: <bytes1> [<count2>: <bytes2>] @ a1 a2 a3 ... an\n"
        "    s/^\\s*//;\n"
        "    s/\\s*$//;\n"
        "    if (m/^\\s*(\\d+):\\s+(\\d+)\\s+\\[\\s*(\\d+):\\s+(\\d+)\\]\\s+@\\s+(.*)$/) {\n"
        "      my $stack = $5;\n"
        "      my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);\n"
        "\n"
        "      if ($sample_adjustment) {\n"
        "        if ($sampling_algorithm == 2) {\n"
        "          # Remote-heap version 2\n"
        "          # The sampling frequency is the rate of a Poisson process.\n"
        "          # This means that the probability of sampling an allocation of\n"
        "          # size X with sampling rate Y is 1 - exp(-X/Y)\n"
        "          if ($n1 != 0) {\n"
        "            my $ratio = (($s1*1.0)/$n1)/($sample_adjustment);\n"
        "            my $scale_factor = 1/(1 - exp(-$ratio));\n"
        "            $n1 *= $scale_factor;\n"
        "            $s1 *= $scale_factor;\n"
        "          }\n"
        "          if ($n2 != 0) {\n"
        "            my $ratio = (($s2*1.0)/$n2)/($sample_adjustment);\n"
        "            my $scale_factor = 1/(1 - exp(-$ratio));\n"
        "            $n2 *= $scale_factor;\n"
        "            $s2 *= $scale_factor;\n"
        "          }\n"
        "        } else {\n"
        "          # Remote-heap version 1\n"
        "          my $ratio;\n"
        "          $ratio = (($s1*1.0)/$n1)/($sample_adjustment);\n"
        "          if ($ratio < 1) {\n"
        "            $n1 /= $ratio;\n"
        "            $s1 /= $ratio;\n"
        "          }\n"
        "          $ratio = (($s2*1.0)/$n2)/($sample_adjustment);\n"
        "          if ($ratio < 1) {\n"
        "            $n2 /= $ratio;\n"
        "            $s2 /= $ratio;\n"
        "          }\n"
        "        }\n"
        "      }\n"
        "\n"
        "      my @counts = ($n1, $s1, $n2, $s2);\n"
        "      $stack = FixCallerAddresses($stack);\n"
        "      push @stackTraces, \"$n1 $s1 $n2 $s2 $stack\";\n"
        "      AddEntries($profile, $pcs, $stack, $counts[$index]);\n"
        "    }\n"
        "  }\n"
        "\n"
        "  my $r = {};\n"
        "  $r->{version} = \"heap\";\n"
        "  $r->{period} = 1;\n"
        "  $r->{profile} = $profile;\n"
        "  $r->{libs} = ParseLibraries($prog, $map, $pcs);\n"
        "  $r->{pcs} = $pcs;\n"
        "  return $r;\n"
        "}\n"
        "\n"
        "sub ReadSynchProfile {\n"
        "  my $prog = shift;\n"
        "  local *PROFILE = shift;\n"
        "  my $header = shift;\n"
        "\n"
        "  my $map = '';\n"
        "  my $profile = {};\n"
        "  my $pcs = {};\n"
        "  my $sampling_period = 1;\n"
        "  my $cyclespernanosec = 2.8;   # Default assumption for old binaries\n"
        "  my $seen_clockrate = 0;\n"
        "  my $line;\n"
        "\n"
        "  my $index = 0;\n"
        "  if ($main::opt_total_delay) {\n"
        "    $index = 0;\n"
        "  } elsif ($main::opt_contentions) {\n"
        "    $index = 1;\n"
        "  } elsif ($main::opt_mean_delay) {\n"
        "    $index = 2;\n"
        "  }\n"
        "\n"
        "  while ( $line = <PROFILE> ) {\n"
        "    $line =~ s/\\r//g;      # turn windows-looking lines into unix-looking lines\n"
        "    # Support negative count for IOBuf Profiler\n"
        "    if ( $line =~ /^\\s*(\\d+)\\s+(-?\\d+) \\@\\s*(.*?)\\s*$/ ) {\n"
        "      my ($cycles, $count, $stack) = ($1, $2, $3);\n"
        "\n"
        "      # Convert cycles to nanoseconds\n"
        "      $cycles /= $cyclespernanosec;\n"
        "\n"
        "      # Adjust for sampling done by application\n"
        "      $cycles *= $sampling_period;\n"
        "      $count *= $sampling_period;\n"
        "\n"
        "      my @values = ($cycles, $count, $cycles / $count);\n"
        "      AddEntries($profile, $pcs, FixCallerAddresses($stack), $values[$index]);\n"
        "\n"
        "    } elsif ( $line =~ /^(slow release).*thread \\d+  \\@\\s*(.*?)\\s*$/ ||\n"
        "              $line =~ /^\\s*(\\d+) \\@\\s*(.*?)\\s*$/ ) {\n"
        "      my ($cycles, $stack) = ($1, $2);\n"
        "      if ($cycles !~ /^\\d+$/) {\n"
        "        next;\n"
        "      }\n"
        "\n"
        "      # Convert cycles to nanoseconds\n"
        "      $cycles /= $cyclespernanosec;\n"
        "\n"
        "      # Adjust for sampling done by application\n"
        "      $cycles *= $sampling_period;\n"
        "\n"
        "      AddEntries($profile, $pcs, FixCallerAddresses($stack), $cycles);\n"
        "\n"
        "    } elsif ( $line =~ m/^([a-z][^=]*)=(.*)$/ ) {\n"
        "      my ($variable, $value) = ($1,$2);\n"
        "      for ($variable, $value) {\n"
        "        s/^\\s+//;\n"
        "        s/\\s+$//;\n"
        "      }\n"
        "      if ($variable eq \"cycles/second\") {\n"
        "        $cyclespernanosec = $value / 1e9;\n"
        "        $seen_clockrate = 1;\n"
        "      } elsif ($variable eq \"sampling period\") {\n"
        "        $sampling_period = $value;\n"
        "      } elsif ($variable eq \"ms since reset\") {\n"
        "        # Currently nothing is done with this value in pprof\n"
        "        # So we just silently ignore it for now\n"
        "      } elsif ($variable eq \"discarded samples\") {\n"
        "        # Currently nothing is done with this value in pprof\n"
        "        # So we just silently ignore it for now\n"
        "      } else {\n"
        "        printf STDERR (\"Ignoring unnknown variable in /contention output: \" .\n"
        "                       \"'%s' = '%s'\\n\",$variable,$value);\n"
        "      }\n"
        "    } else {\n"
        "      # Memory map entry\n"
        "      $map .= $line;\n"
        "    }\n"
        "  }\n"
        "\n"
        "  if (!$seen_clockrate) {\n"
        "    printf STDERR (\"No cycles/second entry in profile; Guessing %.1f GHz\\n\",\n"
        "                   $cyclespernanosec);\n"
        "  }\n"
        "\n"
        "  my $r = {};\n"
        "  $r->{version} = 0;\n"
        "  $r->{period} = $sampling_period;\n"
        "  $r->{profile} = $profile;\n"
        "  $r->{libs} = ParseLibraries($prog, $map, $pcs);\n"
        "  $r->{pcs} = $pcs;\n"
        "  return $r;\n"
        "}\n"
        "\n"
        "# Given a hex value in the form \"0x1abcd\" or \"1abcd\", return either\n"
        "# \"0001abcd\" or \"000000000001abcd\", depending on the current (global)\n"
        "# address length.\n"
        "sub HexExtend {\n"
        "  my $addr = shift;\n"
        "\n"
        "  $addr =~ s/^(0x)?0*//;\n"
        "  my $zeros_needed = $address_length - length($addr);\n"
        "  if ($zeros_needed < 0) {\n"
        "    printf STDERR \"Warning: address $addr is longer than address length "
        "$address_length\\n\";\n"
        "    return $addr;\n"
        "  }\n"
        "  return (\"0\" x $zeros_needed) . $addr;\n"
        "}\n"
        "\n"
        "##### Symbol extraction #####\n"
        "\n"
        "# Aggressively search the lib_prefix values for the given library\n"
        "# If all else fails, just return the name of the library unmodified.\n"
        "# If the lib_prefix is \"/my/path,/other/path\" and $file is \"/lib/dir/mylib.so\"\n"
        "# it will search the following locations in this order, until it finds a file:\n"
        "#   /my/path/lib/dir/mylib.so\n"
        "#   /other/path/lib/dir/mylib.so\n"
        "#   /my/path/dir/mylib.so\n"
        "#   /other/path/dir/mylib.so\n"
        "#   /my/path/mylib.so\n"
        "#   /other/path/mylib.so\n"
        "#   /lib/dir/mylib.so              (returned as last resort)\n"
        "sub FindLibrary {\n"
        "  my $file = shift;\n"
        "  my $suffix = $file;\n"
        "\n"
        "  # Search for the library as described above\n"
        "  do {\n"
        "    foreach my $prefix (@prefix_list) {\n"
        "      my $fullpath = $prefix . $suffix;\n"
        "      if (-e $fullpath) {\n"
        "        return $fullpath;\n"
        "      }\n"
        "    }\n"
        "  } while ($suffix =~ s|^/[^/]+/|/|);\n"
        "  return $file;\n"
        "}\n"
        "\n"
        "# Return path to library with debugging symbols.\n"
        "# For libc libraries, the copy in /usr/lib/debug contains debugging symbols\n"
        "sub DebuggingLibrary {\n"
        "  my $file = shift;\n"
        "  if ($file =~ m|^/| && -f \"/usr/lib/debug$file\") {\n"
        "    return \"/usr/lib/debug$file\";\n"
        "  }\n"
        "  if ($file =~ m|^/| && -f \"/usr/lib/debug$file.debug\") {\n"
        "    return \"/usr/lib/debug$file.debug\";\n"
        "  }\n"
        "  return undef;\n"
        "}\n"
        "\n"
        "# Parse text section header of a library using objdump\n"
        "sub ParseTextSectionHeaderFromObjdump {\n"
        "  my $lib = shift;\n"
        "\n"
        "  my $size = undef;\n"
        "  my $vma;\n"
        "  my $file_offset;\n"
        "  # Get objdump output from the library file to figure out how to\n"
        "  # map between mapped addresses and addresses in the library.\n"
        "  my $cmd = ShellEscape($obj_tool_map{\"objdump\"}, \"-h\", $lib);\n"
        "  open(OBJDUMP, \"$cmd |\") || error(\"$cmd: $!\\n\");\n"
        "  while (<OBJDUMP>) {\n"
        "    s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "    # Idx Name          Size      VMA       LMA       File off  Algn\n"
        "    #  10 .text         00104b2c  420156f0  420156f0  000156f0  2**4\n"
        "    # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file\n"
        "    # offset may still be 8.  But AddressSub below will still handle that.\n"
        "    my @x = split;\n"
        "    if (($#x >= 6) && ($x[1] eq '.text')) {\n"
        "      $size = $x[2];\n"
        "      $vma = $x[3];\n"
        "      $file_offset = $x[5];\n"
        "      last;\n"
        "    }\n"
        "  }\n"
        "  close(OBJDUMP);\n"
        "\n"
        "  if (!defined($size)) {\n"
        "    return undef;\n"
        "  }\n"
        "\n"
        "  my $r = {};\n"
        "  $r->{size} = $size;\n"
        "  $r->{vma} = $vma;\n"
        "  $r->{file_offset} = $file_offset;\n"
        "\n"
        "  return $r;\n"
        "}\n"
        "\n"
        "# Parse text section header of a library using otool (on OS X)\n"
        "sub ParseTextSectionHeaderFromOtool {\n"
        "  my $lib = shift;\n"
        "\n"
        "  my $size = undef;\n"
        "  my $vma = undef;\n"
        "  my $file_offset = undef;\n"
        "  # Get otool output from the library file to figure out how to\n"
        "  # map between mapped addresses and addresses in the library.\n"
        "  my $command = ShellEscape($obj_tool_map{\"otool\"}, \"-l\", $lib);\n"
        "  open(OTOOL, \"$command |\") || error(\"$command: $!\\n\");\n"
        "  my $cmd = \"\";\n"
        "  my $sectname = \"\";\n"
        "  my $segname = \"\";\n"
        "  foreach my $line (<OTOOL>) {\n"
        "    $line =~ s/\\r//g;      # turn windows-looking lines into unix-looking lines\n"
        "    # Load command <#>\n"
        "    #       cmd LC_SEGMENT\n"
        "    # [...]\n"
        "    # Section\n"
        "    #   sectname __text\n"
        "    #    segname __TEXT\n"
        "    #       addr 0x000009f8\n"
        "    #       size 0x00018b9e\n"
        "    #     offset 2552\n"
        "    #      align 2^2 (4)\n"
        "    # We will need to strip off the leading 0x from the hex addresses,\n"
        "    # and convert the offset into hex.\n"
        "    if ($line =~ /Load command/) {\n"
        "      $cmd = \"\";\n"
        "      $sectname = \"\";\n"
        "      $segname = \"\";\n"
        "    } elsif ($line =~ /Section/) {\n"
        "      $sectname = \"\";\n"
        "      $segname = \"\";\n"
        "    } elsif ($line =~ /cmd (\\w+)/) {\n"
        "      $cmd = $1;\n"
        "    } elsif ($line =~ /sectname (\\w+)/) {\n"
        "      $sectname = $1;\n"
        "    } elsif ($line =~ /segname (\\w+)/) {\n"
        "      $segname = $1;\n"
        "    } elsif (!(($cmd eq \"LC_SEGMENT\" || $cmd eq \"LC_SEGMENT_64\") &&\n"
        "               $sectname eq \"__text\" &&\n"
        "               $segname eq \"__TEXT\")) {\n"
        "      next;\n"
        "    } elsif ($line =~ /\\baddr 0x([0-9a-fA-F]+)/) {\n"
        "      $vma = $1;\n"
        "    } elsif ($line =~ /\\bsize 0x([0-9a-fA-F]+)/) {\n"
        "      $size = $1;\n"
        "    } elsif ($line =~ /\\boffset ([0-9]+)/) {\n"
        "      $file_offset = sprintf(\"%016x\", $1);\n"
        "    }\n"
        "    if (defined($vma) && defined($size) && defined($file_offset)) {\n"
        "      last;\n"
        "    }\n"
        "  }\n"
        "  close(OTOOL);\n"
        "\n"
        "  if (!defined($vma) || !defined($size) || !defined($file_offset)) {\n"
        "     return undef;\n"
        "  }\n"
        "\n"
        "  my $r = {};\n"
        "  $r->{size} = $size;\n"
        "  $r->{vma} = $vma;\n"
        "  $r->{file_offset} = $file_offset;\n"
        "\n"
        "  return $r;\n"
        "}\n"
        "\n"
        "sub ParseTextSectionHeader {\n"
        "  # obj_tool_map(\"otool\") is only defined if we're in a Mach-O environment\n"
        "  if (defined($obj_tool_map{\"otool\"})) {\n"
        "    my $r = ParseTextSectionHeaderFromOtool(@_);\n"
        "    if (defined($r)){\n"
        "      return $r;\n"
        "    }\n"
        "  }\n"
        "  # If otool doesn't work, or we don't have it, fall back to objdump\n"
        "  return ParseTextSectionHeaderFromObjdump(@_);\n"
        "}\n"
        "\n"
        "# Split /proc/pid/maps dump into a list of libraries\n"
        "sub ParseLibraries {\n"
        "  return if $main::use_symbol_page;  # We don't need libraries info.\n"
        "  my $prog = Cwd::abs_path(shift);\n"
        "  my $map = shift;\n"
        "  my $pcs = shift;\n"
        "\n"
        "  my $result = [];\n"
        "  my $h = \"[a-f0-9]+\";\n"
        "  my $zero_offset = HexExtend(\"0\");\n"
        "\n"
        "  my $buildvar = \"\";\n"
        "  foreach my $l (split(\"\\n\", $map)) {\n"
        "    if ($l =~ m/^\\s*build=(.*)$/) {\n"
        "      $buildvar = $1;\n"
        "    }\n"
        "\n"
        "    my $start;\n"
        "    my $finish;\n"
        "    my $offset;\n"
        "    my $lib;\n"
        "    if ($l =~ "
        "/^($h)-($h)\\s+..x.\\s+($h)\\s+\\S+:\\S+\\s+\\d+\\s+(.+\\.(so|dll|dylib|bundle|node)(("
        "\\.\\d+)+\\w*(\\.\\d+){0,3})?)$/i) {\n"
        "      # Full line from /proc/self/maps.  Example:\n"
        "      #   40000000-40015000 r-xp 00000000 03:01 12845071   /lib/ld-2.3.2.so\n"
        "      $start = HexExtend($1);\n"
        "      $finish = HexExtend($2);\n"
        "      $offset = HexExtend($3);\n"
        "      $lib = $4;\n"
        "      $lib =~ s|\\\\|/|g;     # turn windows-style paths into unix-style paths\n"
        "    } elsif ($l =~ /^\\s*($h)-($h):\\s*(\\S+\\.so(\\.\\d+)*)/) {\n"
        "      # Cooked line from DumpAddressMap.  Example:\n"
        "      #   40000000-40015000: /lib/ld-2.3.2.so\n"
        "      $start = HexExtend($1);\n"
        "      $finish = HexExtend($2);\n"
        "      $offset = $zero_offset;\n"
        "      $lib = $3;\n"
        "    } elsif (($l =~ /^($h)-($h)\\s+..x.\\s+($h)\\s+\\S+:\\S+\\s+\\d+\\s+(\\S+)$/i) && "
        "($4 eq $prog)) {\n"
        "      # PIEs and address space randomization do not play well with our\n"
        "      # default assumption that main executable is at lowest\n"
        "      # addresses. So we're detecting main executable in\n"
        "      # /proc/self/maps as well.\n"
        "      $start = HexExtend($1);\n"
        "      $finish = HexExtend($2);\n"
        "      $offset = HexExtend($3);\n"
        "      $lib = $4;\n"
        "      $lib =~ s|\\\\|/|g;     # turn windows-style paths into unix-style paths\n"
        "    } else {\n"
        "      next;\n"
        "    }\n"
        "\n"
        "    # Expand \"$build\" variable if available\n"
        "    $lib =~ s/\\$build\\b/$buildvar/g;\n"
        "\n"
        "    $lib = FindLibrary($lib);\n"
        "\n"
        "    # Check for pre-relocated libraries, which use pre-relocated symbol tables\n"
        "    # and thus require adjusting the offset that we'll use to translate\n"
        "    # VM addresses into symbol table addresses.\n"
        "    # Only do this if we're not going to fetch the symbol table from a\n"
        "    # debugging copy of the library.\n"
        "    if (!DebuggingLibrary($lib)) {\n"
        "      my $text = ParseTextSectionHeader($lib);\n"
        "      if (defined($text)) {\n"
        "         my $vma_offset = AddressSub($text->{vma}, $text->{file_offset});\n"
        "         $offset = AddressAdd($offset, $vma_offset);\n"
        "      }\n"
        "    }\n"
        "\n"
        "    push(@{$result}, [$lib, $start, $finish, $offset]);\n"
        "  }\n"
        "\n"
        "  # Append special entry for additional library (not relocated)\n"
        "  if ($main::opt_lib ne \"\") {\n"
        "    my $text = ParseTextSectionHeader($main::opt_lib);\n"
        "    if (defined($text)) {\n"
        "       my $start = $text->{vma};\n"
        "       my $finish = AddressAdd($start, $text->{size});\n"
        "\n"
        "       push(@{$result}, [$main::opt_lib, $start, $finish, $start]);\n"
        "    }\n"
        "  }\n"
        "\n"
        "  # Append special entry for the main program.  This covers\n"
        "  # 0..max_pc_value_seen, so that we assume pc values not found in one\n"
        "  # of the library ranges will be treated as coming from the main\n"
        "  # program binary.\n"
        "  my $min_pc = HexExtend(\"0\");\n"
        "  my $max_pc = $min_pc;          # find the maximal PC value in any sample\n"
        "  foreach my $pc (keys(%{$pcs})) {\n"
        "    if (HexExtend($pc) gt $max_pc) { $max_pc = HexExtend($pc); }\n"
        "  }\n"
        "  push(@{$result}, [$prog, $min_pc, $max_pc, $zero_offset]);\n"
        "\n"
        "  return $result;\n"
        "}\n"
        "\n"
        "# Add two hex addresses of length $address_length.\n"
        "# Run pprof --test for unit test if this is changed.\n"
        "sub AddressAdd {\n"
        "  my $addr1 = shift;\n"
        "  my $addr2 = shift;\n"
        "  my $sum;\n"
        "\n"
        "  if ($address_length == 8) {\n"
        "    # Perl doesn't cope with wraparound arithmetic, so do it explicitly:\n"
        "    $sum = (hex($addr1)+hex($addr2)) % (0x10000000 * 16);\n"
        "    return sprintf(\"%08x\", $sum);\n"
        "\n"
        "  } else {\n"
        "    # Do the addition in 7-nibble chunks to trivialize carry handling.\n"
        "\n"
        "    if ($main::opt_debug and $main::opt_test) {\n"
        "      print STDERR \"AddressAdd $addr1 + $addr2 = \";\n"
        "    }\n"
        "\n"
        "    my $a1 = substr($addr1,-7);\n"
        "    $addr1 = substr($addr1,0,-7);\n"
        "    my $a2 = substr($addr2,-7);\n"
        "    $addr2 = substr($addr2,0,-7);\n"
        "    $sum = hex($a1) + hex($a2);\n"
        "    my $c = 0;\n"
        "    if ($sum > 0xfffffff) {\n"
        "      $c = 1;\n"
        "      $sum -= 0x10000000;\n"
        "    }\n"
        "    my $r = sprintf(\"%07x\", $sum);\n"
        "\n"
        "    $a1 = substr($addr1,-7);\n"
        "    $addr1 = substr($addr1,0,-7);\n"
        "    $a2 = substr($addr2,-7);\n"
        "    $addr2 = substr($addr2,0,-7);\n"
        "    $sum = hex($a1) + hex($a2) + $c;\n"
        "    $c = 0;\n"
        "    if ($sum > 0xfffffff) {\n"
        "      $c = 1;\n"
        "      $sum -= 0x10000000;\n"
        "    }\n"
        "    $r = sprintf(\"%07x\", $sum) . $r;\n"
        "\n"
        "    $sum = hex($addr1) + hex($addr2) + $c;\n"
        "    if ($sum > 0xff) { $sum -= 0x100; }\n"
        "    $r = sprintf(\"%02x\", $sum) . $r;\n"
        "\n"
        "    if ($main::opt_debug and $main::opt_test) { print STDERR \"$r\\n\"; }\n"
        "\n"
        "    return $r;\n"
        "  }\n"
        "}\n"
        "\n"
        "\n"
        "# Subtract two hex addresses of length $address_length.\n"
        "# Run pprof --test for unit test if this is changed.\n"
        "sub AddressSub {\n"
        "  my $addr1 = shift;\n"
        "  my $addr2 = shift;\n"
        "  my $diff;\n"
        "\n"
        "  if ($address_length == 8) {\n"
        "    # Perl doesn't cope with wraparound arithmetic, so do it explicitly:\n"
        "    $diff = (hex($addr1)-hex($addr2)) % (0x10000000 * 16);\n"
        "    return sprintf(\"%08x\", $diff);\n"
        "\n"
        "  } else {\n"
        "    # Do the addition in 7-nibble chunks to trivialize borrow handling.\n"
        "    # if ($main::opt_debug) { print STDERR \"AddressSub $addr1 - $addr2 = \"; }\n"
        "\n"
        "    my $a1 = hex(substr($addr1,-7));\n"
        "    $addr1 = substr($addr1,0,-7);\n"
        "    my $a2 = hex(substr($addr2,-7));\n"
        "    $addr2 = substr($addr2,0,-7);\n"
        "    my $b = 0;\n"
        "    if ($a2 > $a1) {\n"
        "      $b = 1;\n"
        "      $a1 += 0x10000000;\n"
        "    }\n"
        "    $diff = $a1 - $a2;\n"
        "    my $r = sprintf(\"%07x\", $diff);\n"
        "\n"
        "    $a1 = hex(substr($addr1,-7));\n"
        "    $addr1 = substr($addr1,0,-7);\n"
        "    $a2 = hex(substr($addr2,-7)) + $b;\n"
        "    $addr2 = substr($addr2,0,-7);\n"
        "    $b = 0;\n"
        "    if ($a2 > $a1) {\n"
        "      $b = 1;\n"
        "      $a1 += 0x10000000;\n"
        "    }\n"
        "    $diff = $a1 - $a2;\n"
        "    $r = sprintf(\"%07x\", $diff) . $r;\n"
        "\n"
        "    $a1 = hex($addr1);\n"
        "    $a2 = hex($addr2) + $b;\n"
        "    if ($a2 > $a1) { $a1 += 0x100; }\n"
        "    $diff = $a1 - $a2;\n"
        "    $r = sprintf(\"%02x\", $diff) . $r;\n"
        "\n"
        "    # if ($main::opt_debug) { print STDERR \"$r\\n\"; }\n"
        "\n"
        "    return $r;\n"
        "  }\n"
        "}\n"
        "\n"
        "# Increment a hex addresses of length $address_length.\n"
        "# Run pprof --test for unit test if this is changed.\n"
        "sub AddressInc {\n"
        "  my $addr = shift;\n"
        "  my $sum;\n"
        "\n"
        "  if ($address_length == 8) {\n"
        "    # Perl doesn't cope with wraparound arithmetic, so do it explicitly:\n"
        "    $sum = (hex($addr)+1) % (0x10000000 * 16);\n"
        "    return sprintf(\"%08x\", $sum);\n"
        "\n"
        "  } else {\n"
        "    # Do the addition in 7-nibble chunks to trivialize carry handling.\n"
        "    # We are always doing this to step through the addresses in a function,\n"
        "    # and will almost never overflow the first chunk, so we check for this\n"
        "    # case and exit early.\n"
        "\n"
        "    # if ($main::opt_debug) { print STDERR \"AddressInc $addr1 = \"; }\n"
        "\n"
        "    my $a1 = substr($addr,-7);\n"
        "    $addr = substr($addr,0,-7);\n"
        "    $sum = hex($a1) + 1;\n"
        "    my $r = sprintf(\"%07x\", $sum);\n"
        "    if ($sum <= 0xfffffff) {\n"
        "      $r = $addr . $r;\n"
        "      # if ($main::opt_debug) { print STDERR \"$r\\n\"; }\n"
        "      return HexExtend($r);\n"
        "    } else {\n"
        "      $r = \"0000000\";\n"
        "    }\n"
        "\n"
        "    $a1 = substr($addr,-7);\n"
        "    $addr = substr($addr,0,-7);\n"
        "    $sum = hex($a1) + 1;\n"
        "    $r = sprintf(\"%07x\", $sum) . $r;\n"
        "    if ($sum <= 0xfffffff) {\n"
        "      $r = $addr . $r;\n"
        "      # if ($main::opt_debug) { print STDERR \"$r\\n\"; }\n"
        "      return HexExtend($r);\n"
        "    } else {\n"
        "      $r = \"00000000000000\";\n"
        "    }\n"
        "\n"
        "    $sum = hex($addr) + 1;\n"
        "    if ($sum > 0xff) { $sum -= 0x100; }\n"
        "    $r = sprintf(\"%02x\", $sum) . $r;\n"
        "\n"
        "    # if ($main::opt_debug) { print STDERR \"$r\\n\"; }\n"
        "    return $r;\n"
        "  }\n"
        "}\n"
        "\n"
        "# Extract symbols for all PC values found in profile\n"
        "sub ExtractSymbols {\n"
        "  my $libs = shift;\n"
        "  my $pcset = shift;\n"
        "\n"
        "  my $symbols = {};\n"
        "\n"
        "  # Map each PC value to the containing library.  To make this faster,\n"
        "  # we sort libraries by their starting pc value (highest first), and\n"
        "  # advance through the libraries as we advance the pc.  Sometimes the\n"
        "  # addresses of libraries may overlap with the addresses of the main\n"
        "  # binary, so to make sure the libraries 'win', we iterate over the\n"
        "  # libraries in reverse order (which assumes the binary doesn't start\n"
        "  # in the middle of a library, which seems a fair assumption).\n"
        "  my @pcs = (sort { $a cmp $b } keys(%{$pcset}));  # pcset is 0-extended strings\n"
        "  foreach my $lib (sort {$b->[1] cmp $a->[1]} @{$libs}) {\n"
        "    my $libname = $lib->[0];\n"
        "    my $start = $lib->[1];\n"
        "    my $finish = $lib->[2];\n"
        "    my $offset = $lib->[3];\n"
        "\n"
        "    # Get list of pcs that belong in this library.\n"
        "    my $contained = [];\n"
        "    my ($start_pc_index, $finish_pc_index);\n"
        "    # Find smallest finish_pc_index such that $finish < $pc[$finish_pc_index].\n"
        "    for ($finish_pc_index = $#pcs + 1; $finish_pc_index > 0;\n"
        "         $finish_pc_index--) {\n"
        "      last if $pcs[$finish_pc_index - 1] le $finish;\n"
        "    }\n"
        "    # Find smallest start_pc_index such that $start <= $pc[$start_pc_index].\n"
        "    for ($start_pc_index = $finish_pc_index; $start_pc_index > 0;\n"
        "         $start_pc_index--) {\n"
        "      last if $pcs[$start_pc_index - 1] lt $start;\n"
        "    }\n"
        "    # This keeps PC values higher than $pc[$finish_pc_index] in @pcs,\n"
        "    # in case there are overlaps in libraries and the main binary.\n"
        "    @{$contained} = splice(@pcs, $start_pc_index,\n"
        "                           $finish_pc_index - $start_pc_index);\n"
        "    # Map to symbols\n"
        "    MapToSymbols($libname, AddressSub($start, $offset), $contained, $symbols);\n"
        "  }\n"
        "\n"
        "  return $symbols;\n"
        "}\n"
        "\n"
        "# Map list of PC values to symbols for a given image\n"
        "sub MapToSymbols {\n"
        "  my $image = shift;\n"
        "  my $offset = shift;\n"
        "  my $pclist = shift;\n"
        "  my $symbols = shift;\n"
        "\n"
        "  my $debug = 0;\n"
        "\n"
        "  # For libc (and other) libraries, the copy in /usr/lib/debug contains debugging "
        "symbols\n"
        "  my $debugging = DebuggingLibrary($image);\n"
        "  if ($debugging) {\n"
        "    $image = $debugging;\n"
        "  }\n"
        "\n"
        "  # Ignore empty binaries\n"
        "  if ($#{$pclist} < 0) { return; }\n"
        "\n"
        "  # Figure out the addr2line command to use\n"
        "  my $addr2line = $obj_tool_map{\"addr2line\"};\n"
        "  my $cmd = ShellEscape($addr2line, \"-f\", \"-C\", \"-e\", $image);\n"
        "  if (exists $obj_tool_map{\"addr2line_pdb\"}) {\n"
        "    $addr2line = $obj_tool_map{\"addr2line_pdb\"};\n"
        "    $cmd = ShellEscape($addr2line, \"--demangle\", \"-f\", \"-C\", \"-e\", $image);\n"
        "  }\n"
        "\n"
        "  # If \"addr2line\" isn't installed on the system at all, just use\n"
        "  # nm to get what info we can (function names, but not line numbers).\n"
        "  if (system(ShellEscape($addr2line, \"--help\") . \" >$dev_null 2>&1\") != 0) {\n"
        "    MapSymbolsWithNM($image, $offset, $pclist, $symbols);\n"
        "    return;\n"
        "  }\n"
        "\n"
        "  # \"addr2line -i\" can produce a variable number of lines per input\n"
        "  # address, with no separator that allows us to tell when data for\n"
        "  # the next address starts.  So we find the address for a special\n"
        "  # symbol (_fini) and interleave this address between all real\n"
        "  # addresses passed to addr2line.  The name of this special symbol\n"
        "  # can then be used as a separator.\n"
        "  $sep_address = undef;  # May be filled in by MapSymbolsWithNM()\n"
        "  my $nm_symbols = {};\n"
        "  MapSymbolsWithNM($image, $offset, $pclist, $nm_symbols);\n"
        "  if (defined($sep_address)) {\n"
        "    # Only add \" -i\" to addr2line if the binary supports it.\n"
        "    # addr2line --help returns 0, but not if it sees an unknown flag first.\n"
        "    if (system(\"$cmd -i --help >$dev_null 2>&1\") == 0) {\n"
        "      $cmd .= \" -i\";\n"
        "    } else {\n"
        "      $sep_address = undef;   # no need for sep_address if we don't support -i\n"
        "    }\n"
        "  }\n"
        "\n"
        "  # Make file with all PC values with intervening 'sep_address' so\n"
        "  # that we can reliably detect the end of inlined function list\n"
        "  open(ADDRESSES, \">$main::tmpfile_sym\") || error(\"$main::tmpfile_sym: $!\\n\");\n"
        "  if ($debug) { print(\"---- $image ---\\n\"); }\n"
        "  for (my $i = 0; $i <= $#{$pclist}; $i++) {\n"
        "    # addr2line always reads hex addresses, and does not need '0x' prefix.\n"
        "    if ($debug) { printf STDERR (\"%s\\n\", $pclist->[$i]); }\n"
        "    printf ADDRESSES (\"%s\\n\", AddressSub($pclist->[$i], $offset));\n"
        "    if (defined($sep_address)) {\n"
        "      printf ADDRESSES (\"%s\\n\", $sep_address);\n"
        "    }\n"
        "  }\n"
        "  close(ADDRESSES);\n"
        "  if ($debug) {\n"
        "    print(\"----\\n\");\n"
        "    system(\"cat\", $main::tmpfile_sym);\n"
        "    print(\"---- $cmd ---\\n\");\n"
        "    system(\"$cmd < \" . ShellEscape($main::tmpfile_sym));\n"
        "    print(\"----\\n\");\n"
        "  }\n"
        "\n"
        "  open(SYMBOLS, \"$cmd <\" . ShellEscape($main::tmpfile_sym) . \" |\")\n"
        "      || error(\"$cmd: $!\\n\");\n"
        "  my $count = 0;   # Index in pclist\n"
        "  while (<SYMBOLS>) {\n"
        "    # Read fullfunction and filelineinfo from next pair of lines\n"
        "    s/\\r?\\n$//g;\n"
        "    my $fullfunction = $_;\n"
        "    $_ = <SYMBOLS>;\n"
        "    s/\\r?\\n$//g;\n"
        "    my $filelinenum = $_;\n"
        "\n"
        "    if (defined($sep_address) && $fullfunction eq $sep_symbol) {\n"
        "      # Terminating marker for data for this address\n"
        "      $count++;\n"
        "      next;\n"
        "    }\n"
        "\n"
        "    $filelinenum =~ s|\\\\|/|g; # turn windows-style paths into unix-style paths\n"
        "\n"
        "    # Remove discriminator markers as this comes after the line number and\n"
        "    # confuses the rest of this script.\n"
        "    $filelinenum =~ s/ \\(discriminator \\d+\\)$//;\n"
        "    # Convert unknown line numbers into line 0.\n"
        "    $filelinenum =~ s/:\\?$/:0/;\n"
        "\n"
        "    my $pcstr = $pclist->[$count];\n"
        "    my $function = ShortFunctionName($fullfunction);\n"
        "    my $nms = $nm_symbols->{$pcstr};\n"
        "    if (defined($nms)) {\n"
        "      if ($fullfunction eq '\?\?') {\n"
        "        # nm found a symbol for us.\n"
        "        $function = $nms->[0];\n"
        "        $fullfunction = $nms->[2];\n"
        "      } else {\n"
        "	# MapSymbolsWithNM tags each routine with its starting address,\n"
        "	# useful in case the image has multiple occurrences of this\n"
        "	# routine.  (It uses a syntax that resembles template parameters,\n"
        "	# that are automatically stripped out by ShortFunctionName().)\n"
        "	# addr2line does not provide the same information.  So we check\n"
        "	# if nm disambiguated our symbol, and if so take the annotated\n"
        "	# (nm) version of the routine-name.  TODO(csilvers): this won't\n"
        "	# catch overloaded, inlined symbols, which nm doesn't see.\n"
        "	# Better would be to do a check similar to nm's, in this fn.\n"
        "	if ($nms->[2] =~ m/^\\Q$function\\E/) {  # sanity check it's the right fn\n"
        "	  $function = $nms->[0];\n"
        "	  $fullfunction = $nms->[2];\n"
        "	}\n"
        "      }\n"
        "    }\n"
        "    \n"
        "    # Prepend to accumulated symbols for pcstr\n"
        "    # (so that caller comes before callee)\n"
        "    my $sym = $symbols->{$pcstr};\n"
        "    if (!defined($sym)) {\n"
        "      $sym = [];\n"
        "      $symbols->{$pcstr} = $sym;\n"
        "    }\n"
        "    unshift(@{$sym}, $function, $filelinenum, $fullfunction);\n"
        "    if ($debug) { printf STDERR (\"%s => [%s]\\n\", $pcstr, join(\" \", @{$sym})); }\n"
        "    if (!defined($sep_address)) {\n"
        "      # Inlining is off, so this entry ends immediately\n"
        "      $count++;\n"
        "    }\n"
        "  }\n"
        "  close(SYMBOLS);\n"
        "}\n"
        "\n"
        "# Use nm to map the list of referenced PCs to symbols.  Return true iff we\n"
        "# are able to read procedure information via nm.\n"
        "sub MapSymbolsWithNM {\n"
        "  my $image = shift;\n"
        "  my $offset = shift;\n"
        "  my $pclist = shift;\n"
        "  my $symbols = shift;\n"
        "\n"
        "  # Get nm output sorted by increasing address\n"
        "  my $symbol_table = GetProcedureBoundaries($image, \".\");\n"
        "  if (!%{$symbol_table}) {\n"
        "    return 0;\n"
        "  }\n"
        "  # Start addresses are already the right length (8 or 16 hex digits).\n"
        "  my @names = sort { $symbol_table->{$a}->[0] cmp $symbol_table->{$b}->[0] }\n"
        "    keys(%{$symbol_table});\n"
        "\n"
        "  if ($#names < 0) {\n"
        "    # No symbols: just use addresses\n"
        "    foreach my $pc (@{$pclist}) {\n"
        "      my $pcstr = \"0x\" . $pc;\n"
        "      $symbols->{$pc} = [$pcstr, \"?\", $pcstr];\n"
        "    }\n"
        "    return 0;\n"
        "  }\n"
        "\n"
        "  # Sort addresses so we can do a join against nm output\n"
        "  my $index = 0;\n"
        "  my $fullname = $names[0];\n"
        "  my $name = ShortFunctionName($fullname);\n"
        "  foreach my $pc (sort { $a cmp $b } @{$pclist}) {\n"
        "    # Adjust for mapped offset\n"
        "    my $mpc = AddressSub($pc, $offset);\n"
        "    while (($index < $#names) && ($mpc ge $symbol_table->{$fullname}->[1])){\n"
        "      $index++;\n"
        "      $fullname = $names[$index];\n"
        "      $name = ShortFunctionName($fullname);\n"
        "    }\n"
        "    if ($mpc lt $symbol_table->{$fullname}->[1]) {\n"
        "      $symbols->{$pc} = [$name, \"?\", $fullname];\n"
        "    } else {\n"
        "      my $pcstr = \"0x\" . $pc;\n"
        "      $symbols->{$pc} = [$pcstr, \"?\", $pcstr];\n"
        "    }\n"
        "  }\n"
        "  return 1;\n"
        "}\n"
        "\n"
        "sub ShortFunctionName {\n"
        "  my $function = shift;\n"
        "  while ($function =~ s/\\([^()]*\\)(\\s*const)?//g) { }   # Argument types\n"
        "  $function =~ s/<[0-9a-f]*>$//g;                # Remove Address\n"
        "  if (!$main::opt_no_strip_temp) {\n"
        "      while ($function =~ s/<[^<>]*>//g)  { }   # Remove template arguments\n"
        "  }\n"
        "  $function =~ s/^.*\\s+(\\w+::)/$1/;          # Remove leading type\n"
        "  return $function;\n"
        "}\n"
        "\n"
        "# Trim overly long symbols found in disassembler output\n"
        "sub CleanDisassembly {\n"
        "  my $d = shift;\n"
        "  while ($d =~ s/\\([^()%]*\\)(\\s*const)?//g) { } # Argument types, not (%rax)\n"
        "  while ($d =~ s/(\\w+)<[^<>]*>/$1/g)  { }       # Remove template arguments\n"
        "  return $d;\n"
        "}\n"
        "\n"
        "# Clean file name for display\n"
        "sub CleanFileName {\n"
        "  my ($f) = @_;\n"
        "  $f =~ s|^/proc/self/cwd/||;\n"
        "  $f =~ s|^\\./||;\n"
        "  return $f;\n"
        "}\n"
        "\n"
        "# Make address relative to section and clean up for display\n"
        "sub UnparseAddress {\n"
        "  my ($offset, $address) = @_;\n"
        "  $address = AddressSub($address, $offset);\n"
        "  $address =~ s/^0x//;\n"
        "  $address =~ s/^0*//;\n"
        "  return $address;\n"
        "}\n"
        "\n"
        "##### Miscellaneous #####\n"
        "\n"
        "# Find the right versions of the above object tools to use.  The\n"
        "# argument is the program file being analyzed, and should be an ELF\n"
        "# 32-bit or ELF 64-bit executable file.  The location of the tools\n"
        "# is determined by considering the following options in this order:\n"
        "#   1) --tools option, if set\n"
        "#   2) PPROF_TOOLS environment variable, if set\n"
        "#   3) the environment\n"
        "sub ConfigureObjTools {\n"
        "  my $prog_file = shift;\n"
        "\n"
        "  # Check for the existence of $prog_file because /usr/bin/file does not\n"
        "  # predictably return error status in prod.\n"
        "  (-e $prog_file)  || error(\"$prog_file does not exist.\\n\");\n"
        "\n"
        "  my $file_type = undef;\n"
        "  if (-e \"/usr/bin/file\") {\n"
        "    # Follow symlinks (at least for systems where \"file\" supports that).\n"
        "    my $escaped_prog_file = ShellEscape($prog_file);\n"
        "    $file_type = `/usr/bin/file -L $escaped_prog_file 2>$dev_null ||\n"
        "                  /usr/bin/file $escaped_prog_file`;\n"
        "  } elsif ($^O == \"MSWin32\") {\n"
        "    $file_type = \"MS Windows\";\n"
        "  } else {\n"
        "    print STDERR \"WARNING: Can't determine the file type of $prog_file\";\n"
        "  }\n"
        "\n"
        "  if ($file_type =~ /64-bit/) {\n"
        "    # Change $address_length to 16 if the program file is ELF 64-bit.\n"
        "    # We can't detect this from many (most?) heap or lock contention\n"
        "    # profiles, since the actual addresses referenced are generally in low\n"
        "    # memory even for 64-bit programs.\n"
        "    $address_length = 16;\n"
        "  }\n"
        "\n"
        "  if ($file_type =~ /MS Windows/) {\n"
        "    # For windows, we provide a version of nm and addr2line as part of\n"
        "    # the opensource release, which is capable of parsing\n"
        "    # Windows-style PDB executables.  It should live in the path, or\n"
        "    # in the same directory as pprof.\n"
        "    $obj_tool_map{\"nm_pdb\"} = \"nm-pdb\";\n"
        "    $obj_tool_map{\"addr2line_pdb\"} = \"addr2line-pdb\";\n"
        "  }\n"
        "\n"
        "  if ($file_type =~ /Mach-O/) {\n"
        "    # OS X uses otool to examine Mach-O files, rather than objdump.\n"
        "    $obj_tool_map{\"otool\"} = \"otool\";\n"
        "    $obj_tool_map{\"addr2line\"} = \"false\";  # no addr2line\n"
        "    $obj_tool_map{\"objdump\"} = \"false\";  # no objdump\n"
        "  }\n"
        "\n"
        "  # Go fill in %obj_tool_map with the pathnames to use:\n"
        "  foreach my $tool (keys %obj_tool_map) {\n"
        "    $obj_tool_map{$tool} = ConfigureTool($obj_tool_map{$tool});\n"
        "  }\n"
        "}\n"
        "\n"
        "# Returns the path of a caller-specified object tool.  If --tools or\n"
        "# PPROF_TOOLS are specified, then returns the full path to the tool\n"
        "# with that prefix.  Otherwise, returns the path unmodified (which\n"
        "# means we will look for it on PATH).\n"
        "sub ConfigureTool {\n"
        "  my $tool = shift;\n"
        "  my $path;\n"
        "\n"
        "  # --tools (or $PPROF_TOOLS) is a comma separated list, where each\n"
        "  # item is either a) a pathname prefix, or b) a map of the form\n"
        "  # <tool>:<path>.  First we look for an entry of type (b) for our\n"
        "  # tool.  If one is found, we use it.  Otherwise, we consider all the\n"
        "  # pathname prefixes in turn, until one yields an existing file.  If\n"
        "  # none does, we use a default path.\n"
        "  my $tools = $main::opt_tools || $ENV{\"PPROF_TOOLS\"} || \"\";\n"
        "  if ($tools =~ m/(,|^)\\Q$tool\\E:([^,]*)/) {\n"
        "    $path = $2;\n"
        "    # TODO(csilvers): sanity-check that $path exists?  Hard if it's relative.\n"
        "  } elsif ($tools ne '') {\n"
        "    foreach my $prefix (split(',', $tools)) {\n"
        "      next if ($prefix =~ /:/);    # ignore \"tool:fullpath\" entries in the list\n"
        "      if (-x $prefix . $tool) {\n"
        "        $path = $prefix . $tool;\n"
        "        last;\n"
        "      }\n"
        "    }\n"
        "    if (!$path) {\n"
        "      error(\"No '$tool' found with prefix specified by \" .\n"
        "            \"--tools (or \\$PPROF_TOOLS) '$tools'\\n\");\n"
        "    }\n"
        "  } else {\n"
        "    # ... otherwise use the version that exists in the same directory as\n"
        "    # pprof.  If there's nothing there, use $PATH.\n"
        "    $0 =~ m,[^/]*$,;     # this is everything after the last slash\n"
        "    my $dirname = $`;    # this is everything up to and including the last slash\n"
        "    if (-x \"$dirname$tool\") {\n"
        "      $path = \"$dirname$tool\";\n"
        "    } else { \n"
        "      $path = $tool;\n"
        "    }\n"
        "  }\n"
        "  if ($main::opt_debug) { print STDERR \"Using '$path' for '$tool'.\\n\"; }\n"
        "  return $path;\n"
        "}\n"
        "\n"
        "sub ShellEscape {\n"
        "  my @escaped_words = ();\n"
        "  foreach my $word (@_) {\n"
        "    my $escaped_word = $word;\n"
        "    if ($word =~ m![^a-zA-Z0-9/.,_=-]!) {  # check for anything not in whitelist\n"
        "      $escaped_word =~ s/'/'\\\\''/;\n"
        "      $escaped_word = \"'$escaped_word'\";\n"
        "    }\n"
        "    push(@escaped_words, $escaped_word);\n"
        "  }\n"
        "  return join(\" \", @escaped_words);\n"
        "}\n"
        "\n"
        "sub cleanup {\n"
        "  unlink($main::tmpfile_sym);\n"
        "  unlink(keys %main::tempnames);\n"
        "\n"
        "  # We leave any collected profiles in $HOME/pprof in case the user wants\n"
        "  # to look at them later.  We print a message informing them of this.\n"
        "  if ((scalar(@main::profile_files) > 0) &&\n"
        "      defined($main::collected_profile)) {\n"
        "    if (scalar(@main::profile_files) == 1) {\n"
        "      print STDERR \"Dynamically gathered profile is in "
        "$main::collected_profile\\n\";\n"
        "    }\n"
        "    print STDERR \"If you want to investigate this profile further, you can do:\\n\";\n"
        "    print STDERR \"\\n\";\n"
        "    print STDERR \"  $0 \\\\\\n\";\n"
        "    print STDERR \"    $main::prog \\\\\\n\";\n"
        "    print STDERR \"    $main::collected_profile\\n\";\n"
        "    print STDERR \"\\n\";\n"
        "  }\n"
        "}\n"
        "\n"
        "sub sighandler {\n"
        "  cleanup();\n"
        "  exit(1);\n"
        "}\n"
        "\n"
        "sub error {\n"
        "  my $msg = shift;\n"
        "  print STDERR $msg;\n"
        "  cleanup();\n"
        "  exit(1);\n"
        "}\n"
        "\n"
        "\n"
        "# Run $nm_command and get all the resulting procedure boundaries whose\n"
        "# names match \"$regexp\" and returns them in a hashtable mapping from\n"
        "# procedure name to a two-element vector of [start address, end address]\n"
        "sub GetProcedureBoundariesViaNm {\n"
        "  my $escaped_nm_command = shift;    # shell-escaped\n"
        "  my $regexp = shift;\n"
        "  my $image = shift;\n"
        "\n"
        "  my $symbol_table = {};\n"
        "  open(NM, \"$escaped_nm_command |\") || error(\"$escaped_nm_command: $!\\n\");\n"
        "  my $last_start = \"0\";\n"
        "  my $routine = \"\";\n"
        "  while (<NM>) {\n"
        "    s/\\r//g;         # turn windows-looking lines into unix-looking lines\n"
        "    if (m/^\\s*([0-9a-f]+) (.) (..*)/) {\n"
        "      my $start_val = $1;\n"
        "      my $type = $2;\n"
        "      my $this_routine = $3;\n"
        "\n"
        "      # It's possible for two symbols to share the same address, if\n"
        "      # one is a zero-length variable (like __start_google_malloc) or\n"
        "      # one symbol is a weak alias to another (like __libc_malloc).\n"
        "      # In such cases, we want to ignore all values except for the\n"
        "      # actual symbol, which in nm-speak has type \"T\".  The logic\n"
        "      # below does this, though it's a bit tricky: what happens when\n"
        "      # we have a series of lines with the same address, is the first\n"
        "      # one gets queued up to be processed.  However, it won't\n"
        "      # *actually* be processed until later, when we read a line with\n"
        "      # a different address.  That means that as long as we're reading\n"
        "      # lines with the same address, we have a chance to replace that\n"
        "      # item in the queue, which we do whenever we see a 'T' entry --\n"
        "      # that is, a line with type 'T'.  If we never see a 'T' entry,\n"
        "      # we'll just go ahead and process the first entry (which never\n"
        "      # got touched in the queue), and ignore the others.\n"
        "      if ($start_val eq $last_start && $type =~ /t/i) {\n"
        "        # We are the 'T' symbol at this address, replace previous symbol.\n"
        "        $routine = $this_routine;\n"
        "        next;\n"
        "      } elsif ($start_val eq $last_start) {\n"
        "        # We're not the 'T' symbol at this address, so ignore us.\n"
        "        next;\n"
        "      }\n"
        "\n"
        "      if ($this_routine eq $sep_symbol) {\n"
        "        $sep_address = HexExtend($start_val);\n"
        "      }\n"
        "\n"
        "      # Tag this routine with the starting address in case the image\n"
        "      # has multiple occurrences of this routine.  We use a syntax\n"
        "      # that resembles template parameters that are automatically\n"
        "      # stripped out by ShortFunctionName()\n"
        "      $this_routine .= \"<$start_val>\";\n"
        "\n"
        "      if (defined($routine) && $routine =~ m/$regexp/) {\n"
        "        $symbol_table->{$routine} = [HexExtend($last_start),\n"
        "                                     HexExtend($start_val)];\n"
        "      }\n"
        "      $last_start = $start_val;\n"
        "      $routine = $this_routine;\n"
        "    } elsif (m/^Loaded image name: (.+)/) {\n"
        "      # The win32 nm workalike emits information about the binary it is using.\n"
        "      if ($main::opt_debug) { print STDERR \"Using Image $1\\n\"; }\n"
        "    } elsif (m/^PDB file name: (.+)/) {\n"
        "      # The win32 nm workalike emits information about the pdb it is using.\n"
        "      if ($main::opt_debug) { print STDERR \"Using PDB $1\\n\"; }\n"
        "    }\n"
        "  }\n"
        "  close(NM);\n"
        "  # Handle the last line in the nm output.  Unfortunately, we don't know\n"
        "  # how big this last symbol is, because we don't know how big the file\n"
        "  # is.  For now, we just give it a size of 0.\n"
        "  # TODO(csilvers): do better here.\n"
        "  if (defined($routine) && $routine =~ m/$regexp/) {\n"
        "    $symbol_table->{$routine} = [HexExtend($last_start),\n"
        "                                 HexExtend($last_start)];\n"
        "  }\n"
        "\n"
        "  # Verify if addr2line can find the $sep_symbol.  If not, we use objdump\n"
        "  # to find the address for the $sep_symbol on code section which addr2line\n"
        "  # can find.\n"
        "  if (defined($sep_address)){\n"
        "    my $start_val = $sep_address;\n"
        "    my $addr2line = $obj_tool_map{\"addr2line\"};\n"
        "    my $cmd = ShellEscape($addr2line, \"-f\", \"-C\", \"-e\", $image, \"-i\");\n"
        "    open(FINI, \"echo $start_val | $cmd  |\")\n"
        "         || error(\"echo $start_val | $cmd: $!\\n\");\n"
        "    $_ = <FINI>;\n"
        "    s/\\r?\\n$//g;\n"
        "    my $fini = $_;\n"
        "    close(FINI);\n"
        "    if ($fini ne $sep_symbol){\n"
        "      my $objdump =  $obj_tool_map{\"objdump\"};\n"
        "      $cmd = ShellEscape($objdump, \"-d\", $image);\n"
        "      my $grep = ShellEscape(\"grep\", $sep_symbol);\n"
        "      my $tail = ShellEscape(\"tail\", \"-n\", \"1\");\n"
        "      open(FINI, \"$cmd | $grep | $tail |\")\n"
        "           || error(\"$cmd | $grep | $tail: $!\\n\");\n"
        "      s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
        "      my $data = <FINI>;\n"
        "      if (defined($data)){\n"
        "        ($start_val, $fini) = split(/ </,$data);\n"
        "      }\n"
        "      close(FINI);\n"
        "    }\n"
        "    $sep_address = HexExtend($start_val);\n"
        "  }\n"
        "\n"
        "  return $symbol_table;\n"
        "}\n"
        "\n"
        "# Gets the procedure boundaries for all routines in \"$image\" whose names\n"
        "# match \"$regexp\" and returns them in a hashtable mapping from procedure\n"
        "# name to a two-element vector of [start address, end address].\n"
        "# Will return an empty map if nm is not installed or not working properly.\n"
        "sub GetProcedureBoundaries {\n"
        "  my $image = shift;\n"
        "  my $regexp = shift;\n"
        "\n"
        "  # If $image doesn't start with /, then put ./ in front of it.  This works\n"
        "  # around an obnoxious bug in our probing of nm -f behavior.\n"
        "  # \"nm -f $image\" is supposed to fail on GNU nm, but if:\n"
        "  #\n"
        "  # a. $image starts with [BbSsPp] (for example, bin/foo/bar), AND\n"
        "  # b. you have a.out in your current directory (a not uncommon occurrence)\n"
        "  #\n"
        "  # then \"nm -f $image\" succeeds because -f only looks at the first letter of\n"
        "  # the argument, which looks valid because it's [BbSsPp], and then since\n"
        "  # there's no image provided, it looks for a.out and finds it.\n"
        "  #\n"
        "  # This regex makes sure that $image starts with . or /, forcing the -f\n"
        "  # parsing to fail since . and / are not valid formats.\n"
        "  $image =~ s#^[^/]#./$&#;\n"
        "\n"
        "  # For libc libraries, the copy in /usr/lib/debug contains debugging symbols\n"
        "  my $debugging = DebuggingLibrary($image);\n"
        "  if ($debugging) {\n"
        "    $image = $debugging;\n"
        "  }\n"
        "\n"
        "  my $nm = $obj_tool_map{\"nm\"};\n"
        "  my $cppfilt = $obj_tool_map{\"c++filt\"};\n"
        "\n"
        "  # nm can fail for two reasons: 1) $image isn't a debug library; 2) nm\n"
        "  # binary doesn't support --demangle.  In addition, for OS X we need\n"
        "  # to use the -f flag to get 'flat' nm output (otherwise we don't sort\n"
        "  # properly and get incorrect results).  Unfortunately, GNU nm uses -f\n"
        "  # in an incompatible way.  So first we test whether our nm supports\n"
        "  # --demangle and -f.\n"
        "  my $demangle_flag = \"\";\n"
        "  my $cppfilt_flag = \"\";\n"
        "  my $to_devnull = \">$dev_null 2>&1\";\n"
        "  if (system(ShellEscape($nm, \"--demangle\", $image) . $to_devnull) == 0) {\n"
        "    # In this mode, we do \"nm --demangle <foo>\"\n"
        "    $demangle_flag = \"--demangle\";\n"
        "    $cppfilt_flag = \"\";\n"
        "  } elsif (system(ShellEscape($cppfilt, $image) . $to_devnull) == 0) {\n"
        "    # In this mode, we do \"nm <foo> | c++filt\"\n"
        "    $cppfilt_flag = \" | \" . ShellEscape($cppfilt);\n"
        "  };\n"
        "  my $flatten_flag = \"\";\n"
        "  if (system(ShellEscape($nm, \"-f\", $image) . $to_devnull) == 0) {\n"
        "    $flatten_flag = \"-f\";\n"
        "  }\n"
        "\n"
        "  # Finally, in the case $imagie isn't a debug library, we try again with\n"
        "  # -D to at least get *exported* symbols.  If we can't use --demangle,\n"
        "  # we use c++filt instead, if it exists on this system.\n"
        "  my @nm_commands = (ShellEscape($nm, \"-n\", $flatten_flag, $demangle_flag,\n"
        "                                 $image) . \" 2>$dev_null $cppfilt_flag\",\n"
        "                     ShellEscape($nm, \"-D\", \"-n\", $flatten_flag, $demangle_flag,\n"
        "                                 $image) . \" 2>$dev_null $cppfilt_flag\",\n"
        "                     # 6nm is for Go binaries\n"
        "                     ShellEscape(\"6nm\", \"$image\") . \" 2>$dev_null | sort\",\n"
        "                     );\n"
        "\n"
        "  # If the executable is an MS Windows PDB-format executable, we'll\n"
        "  # have set up obj_tool_map(\"nm_pdb\").  In this case, we actually\n"
        "  # want to use both unix nm and windows-specific nm_pdb, since\n"
        "  # PDB-format executables can apparently include dwarf .o files.\n"
        "  if (exists $obj_tool_map{\"nm_pdb\"}) {\n"
        "    push(@nm_commands,\n"
        "         ShellEscape($obj_tool_map{\"nm_pdb\"}, \"--demangle\", $image)\n"
        "         . \" 2>$dev_null\");\n"
        "  }\n"
        "\n"
        "  foreach my $nm_command (@nm_commands) {\n"
        "    my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp, $image);\n"
        "    return $symbol_table if (%{$symbol_table});\n"
        "  }\n"
        "  my $symbol_table = {};\n"
        "  return $symbol_table;\n"
        "}\n"
        "\n"
        "\n"
        "# The test vectors for AddressAdd/Sub/Inc are 8-16-nibble hex strings.\n"
        "# To make them more readable, we add underscores at interesting places.\n"
        "# This routine removes the underscores, producing the canonical representation\n"
        "# used by pprof to represent addresses, particularly in the tested routines.\n"
        "sub CanonicalHex {\n"
        "  my $arg = shift;\n"
        "  return join '', (split '_',$arg);\n"
        "}\n"
        "\n"
        "\n"
        "# Unit test for AddressAdd:\n"
        "sub AddressAddUnitTest {\n"
        "  my $test_data_8 = shift;\n"
        "  my $test_data_16 = shift;\n"
        "  my $error_count = 0;\n"
        "  my $fail_count = 0;\n"
        "  my $pass_count = 0;\n"
        "  # print STDERR \"AddressAddUnitTest: \", 1+$#{$test_data_8}, \" tests\\n\";\n"
        "\n"
        "  # First a few 8-nibble addresses.  Note that this implementation uses\n"
        "  # plain old arithmetic, so a quick sanity check along with verifying what\n"
        "  # happens to overflow (we want it to wrap):\n"
        "  $address_length = 8;\n"
        "  foreach my $row (@{$test_data_8}) {\n"
        "    if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
        "    my $sum = AddressAdd ($row->[0], $row->[1]);\n"
        "    if ($sum ne $row->[2]) {\n"
        "      printf STDERR \"ERROR: %s != %s + %s = %s\\n\", $sum,\n"
        "             $row->[0], $row->[1], $row->[2];\n"
        "      ++$fail_count;\n"
        "    } else {\n"
        "      ++$pass_count;\n"
        "    }\n"
        "  }\n"
        "  printf STDERR \"AddressAdd 32-bit tests: %d passes, %d failures\\n\",\n"
        "         $pass_count, $fail_count;\n"
        "  $error_count = $fail_count;\n"
        "  $fail_count = 0;\n"
        "  $pass_count = 0;\n"
        "\n"
        "  # Now 16-nibble addresses.\n"
        "  $address_length = 16;\n"
        "  foreach my $row (@{$test_data_16}) {\n"
        "    if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
        "    my $sum = AddressAdd (CanonicalHex($row->[0]), CanonicalHex($row->[1]));\n"
        "    my $expected = join '', (split '_',$row->[2]);\n"
        "    if ($sum ne CanonicalHex($row->[2])) {\n"
        "      printf STDERR \"ERROR: %s != %s + %s = %s\\n\", $sum,\n"
        "             $row->[0], $row->[1], $row->[2];\n"
        "      ++$fail_count;\n"
        "    } else {\n"
        "      ++$pass_count;\n"
        "    }\n"
        "  }\n"
        "  printf STDERR \"AddressAdd 64-bit tests: %d passes, %d failures\\n\",\n"
        "         $pass_count, $fail_count;\n"
        "  $error_count += $fail_count;\n"
        "\n"
        "  return $error_count;\n"
        "}\n"
        "\n"
        "\n"
        "# Unit test for AddressSub:\n"
        "sub AddressSubUnitTest {\n"
        "  my $test_data_8 = shift;\n"
        "  my $test_data_16 = shift;\n"
        "  my $error_count = 0;\n"
        "  my $fail_count = 0;\n"
        "  my $pass_count = 0;\n"
        "  # print STDERR \"AddressSubUnitTest: \", 1+$#{$test_data_8}, \" tests\\n\";\n"
        "\n"
        "  # First a few 8-nibble addresses.  Note that this implementation uses\n"
        "  # plain old arithmetic, so a quick sanity check along with verifying what\n"
        "  # happens to overflow (we want it to wrap):\n"
        "  $address_length = 8;\n"
        "  foreach my $row (@{$test_data_8}) {\n"
        "    if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
        "    my $sum = AddressSub ($row->[0], $row->[1]);\n"
        "    if ($sum ne $row->[3]) {\n"
        "      printf STDERR \"ERROR: %s != %s - %s = %s\\n\", $sum,\n"
        "             $row->[0], $row->[1], $row->[3];\n"
        "      ++$fail_count;\n"
        "    } else {\n"
        "      ++$pass_count;\n"
        "    }\n"
        "  }\n"
        "  printf STDERR \"AddressSub 32-bit tests: %d passes, %d failures\\n\",\n"
        "         $pass_count, $fail_count;\n"
        "  $error_count = $fail_count;\n"
        "  $fail_count = 0;\n"
        "  $pass_count = 0;\n"
        "\n"
        "  # Now 16-nibble addresses.\n"
        "  $address_length = 16;\n"
        "  foreach my $row (@{$test_data_16}) {\n"
        "    if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
        "    my $sum = AddressSub (CanonicalHex($row->[0]), CanonicalHex($row->[1]));\n"
        "    if ($sum ne CanonicalHex($row->[3])) {\n"
        "      printf STDERR \"ERROR: %s != %s - %s = %s\\n\", $sum,\n"
        "             $row->[0], $row->[1], $row->[3];\n"
        "      ++$fail_count;\n"
        "    } else {\n"
        "      ++$pass_count;\n"
        "    }\n"
        "  }\n"
        "  printf STDERR \"AddressSub 64-bit tests: %d passes, %d failures\\n\",\n"
        "         $pass_count, $fail_count;\n"
        "  $error_count += $fail_count;\n"
        "\n"
        "  return $error_count;\n"
        "}\n"
        "\n"
        "\n"
        "# Unit test for AddressInc:\n"
        "sub AddressIncUnitTest {\n"
        "  my $test_data_8 = shift;\n"
        "  my $test_data_16 = shift;\n"
        "  my $error_count = 0;\n"
        "  my $fail_count = 0;\n"
        "  my $pass_count = 0;\n"
        "  # print STDERR \"AddressIncUnitTest: \", 1+$#{$test_data_8}, \" tests\\n\";\n"
        "\n"
        "  # First a few 8-nibble addresses.  Note that this implementation uses\n"
        "  # plain old arithmetic, so a quick sanity check along with verifying what\n"
        "  # happens to overflow (we want it to wrap):\n"
        "  $address_length = 8;\n"
        "  foreach my $row (@{$test_data_8}) {\n"
        "    if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
        "    my $sum = AddressInc ($row->[0]);\n"
        "    if ($sum ne $row->[4]) {\n"
        "      printf STDERR \"ERROR: %s != %s + 1 = %s\\n\", $sum,\n"
        "             $row->[0], $row->[4];\n"
        "      ++$fail_count;\n"
        "    } else {\n"
        "      ++$pass_count;\n"
        "    }\n"
        "  }\n"
        "  printf STDERR \"AddressInc 32-bit tests: %d passes, %d failures\\n\",\n"
        "         $pass_count, $fail_count;\n"
        "  $error_count = $fail_count;\n"
        "  $fail_count = 0;\n"
        "  $pass_count = 0;\n"
        "\n"
        "  # Now 16-nibble addresses.\n"
        "  $address_length = 16;\n"
        "  foreach my $row (@{$test_data_16}) {\n"
        "    if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
        "    my $sum = AddressInc (CanonicalHex($row->[0]));\n"
        "    if ($sum ne CanonicalHex($row->[4])) {\n"
        "      printf STDERR \"ERROR: %s != %s + 1 = %s\\n\", $sum,\n"
        "             $row->[0], $row->[4];\n"
        "      ++$fail_count;\n"
        "    } else {\n"
        "      ++$pass_count;\n"
        "    }\n"
        "  }\n"
        "  printf STDERR \"AddressInc 64-bit tests: %d passes, %d failures\\n\",\n"
        "         $pass_count, $fail_count;\n"
        "  $error_count += $fail_count;\n"
        "\n"
        "  return $error_count;\n"
        "}\n"
        "\n"
        "\n"
        "# Driver for unit tests.\n"
        "# Currently just the address add/subtract/increment routines for 64-bit.\n"
        "sub RunUnitTests {\n"
        "  my $error_count = 0;\n"
        "\n"
        "  # This is a list of tuples [a, b, a+b, a-b, a+1]\n"
        "  my $unit_test_data_8 = [\n"
        "    [qw(aaaaaaaa 50505050 fafafafa 5a5a5a5a aaaaaaab)],\n"
        "    [qw(50505050 aaaaaaaa fafafafa a5a5a5a6 50505051)],\n"
        "    [qw(ffffffff aaaaaaaa aaaaaaa9 55555555 00000000)],\n"
        "    [qw(00000001 ffffffff 00000000 00000002 00000002)],\n"
        "    [qw(00000001 fffffff0 fffffff1 00000011 00000002)],\n"
        "  ];\n"
        "  my $unit_test_data_16 = [\n"
        "    # The implementation handles data in 7-nibble chunks, so those are the\n"
        "    # interesting boundaries.\n"
        "    [qw(aaaaaaaa 50505050\n"
        "        00_000000f_afafafa 00_0000005_a5a5a5a 00_000000a_aaaaaab)],\n"
        "    [qw(50505050 aaaaaaaa\n"
        "        00_000000f_afafafa ff_ffffffa_5a5a5a6 00_0000005_0505051)],\n"
        "    [qw(ffffffff aaaaaaaa\n"
        "        00_000001a_aaaaaa9 00_0000005_5555555 00_0000010_0000000)],\n"
        "    [qw(00000001 ffffffff\n"
        "        00_0000010_0000000 ff_ffffff0_0000002 00_0000000_0000002)],\n"
        "    [qw(00000001 fffffff0\n"
        "        00_000000f_ffffff1 ff_ffffff0_0000011 00_0000000_0000002)],\n"
        "\n"
        "    [qw(00_a00000a_aaaaaaa 50505050\n"
        "        00_a00000f_afafafa 00_a000005_a5a5a5a 00_a00000a_aaaaaab)],\n"
        "    [qw(0f_fff0005_0505050 aaaaaaaa\n"
        "        0f_fff000f_afafafa 0f_ffefffa_5a5a5a6 0f_fff0005_0505051)],\n"
        "    [qw(00_000000f_fffffff 01_800000a_aaaaaaa\n"
        "        01_800001a_aaaaaa9 fe_8000005_5555555 00_0000010_0000000)],\n"
        "    [qw(00_0000000_0000001 ff_fffffff_fffffff\n"
        "        00_0000000_0000000 00_0000000_0000002 00_0000000_0000002)],\n"
        "    [qw(00_0000000_0000001 ff_fffffff_ffffff0\n"
        "        ff_fffffff_ffffff1 00_0000000_0000011 00_0000000_0000002)],\n"
        "  ];\n"
        "\n"
        "  $error_count += AddressAddUnitTest($unit_test_data_8, $unit_test_data_16);\n"
        "  $error_count += AddressSubUnitTest($unit_test_data_8, $unit_test_data_16);\n"
        "  $error_count += AddressIncUnitTest($unit_test_data_8, $unit_test_data_16);\n"
        "  if ($error_count > 0) {\n"
        "    print STDERR $error_count, \" errors: FAILED\\n\";\n"
        "  } else {\n"
        "    print STDERR \"PASS\\n\";\n"
        "  }\n"
        "  exit ($error_count);\n"
        "}\n";
}

} // namespace brpc
