#!/usr/bin/perl

# https://perlmonks.org/?node_id=11105353
# following spirit of my http://www.rosettacode.org/wiki/Compiler/lexical_analyzer#Alternate_Perl_Solution

use strict;
use warnings;

my @tokens;
my %reserved = map { $_ => 'reserved' } qw(
  alignas alignof and and_eq asm atomic_cancel atomic_commit
  atomic_noexcept auto bitand bitor bool break case catch char
  char16_t char32_t class compl concept const constexpr const_cast
  continue co_await co_return co_yield decltype default delete do
  double dynamic_cast else enum explicit export extern false float for
  friend goto if import inline int long module mutable namespace new
  noexcept not not_eq nullptr operator or or_eq private protected
  public register reinterpret_cast requires return short signed
  sizeof static static_assert static_cast struct switch synchronized
  template this thread_local throw true try typedef typeid typename
  union unsigned using virtual void volatile wchar_t while xor xor_eq
  );
my %Ops = ( # Single or multiple operators by name
        '('  => 'LeftParen',
        ')'  => 'RightParen',
        '['  => 'LeftSquare',
        ']'  => 'RightSquare',
        '{'  => 'LeftCurly',
        '}'  => 'RightCurly',
        '<'  => 'LessThan',
        '>'  => 'GreaterThan',
        '='  => 'Equal',
        '+'  => 'Plus',
        '-'  => 'Minus',
        '*'  => 'Asterisk',
        '/'  => 'Slash',
        '#'  => 'Hash',
        '.'  => 'Dot',
        ','  => 'Comma',
        ':'  => 'Colon',
        ';'  => 'Semicolon',
        "'"  => 'SingleQuote',
        '"'  => 'DoubleQuote',
        '|'  => 'Pipe',
        '>>' => 'RightShift', # remember to sort by longest first
        '<<' => 'LeftShift',
        '<=' => 'LessThanOrEqual',
        '>=' => 'GreaterThanOrEqual',
        '||' => 'LogicalOr',
        '&&' => 'LogicalAnd',
        '+=' => 'PlusEqual',
        '-=' => 'MinusEqual',
        '*=' => 'TimesEqual',
        '/=' => 'DivideEqual',
        );
my $matchops = qr/(?:@{[ join '|', map quotemeta,
  sort { length $b <=> length $a }                     # longest first
  sort keys %Ops ]})/;
my $regex = qr/ \G (?|
    \s+                   (?{ undef })
  | \/\/.*                (?{ undef })
  | \/\*[\s\S]*?\*\/      (?{ undef }) # assuming non-nested
  | \#(.+)                (?{ [ 'Directive', $1 ] })
  | \d+(?:\.\d*)?         (?{ 'Number' })
  | \.\d+                 (?{ 'Number' })
  | \w+                   (?{ $reserved{$&} or 'Identifier' })
  | "((?:\\.|[^\\\n"])*)" (?{ [ 'string', $1 =~ s!\\(.)!$1!gr ] })
  | '([^\\'\n])'          (?{ [ 'Number', ord $1 ] })
  | (?<!:)::(?!:)         (?{ 'dblColon' })
  | $matchops             (?{ $Ops{$&} })
  | .                     (?{ 'ERROR: unexpected character' })
  ) /x;

$_ = (join '', <DATA>) =~ s/\\\n/ /gr;
defined $^R and push @tokens, [ ref $^R ? @{$^R} : ( $^R, $& ), $-[0] ]
  while /$regex/g;
use Data::Dump 'dd'; dd @tokens;

__DATA__
#define TheAnswerToLifeTheUniverseAndEverything \
  (42)
int main(int argc, char *argv[ ])
  {
  int $foo = 1 << 5;
  /* multiline
    comment */
  puts("testing a \"quoted\" string with $ sign");
  exit(0); // success
  }