Perl: skip string literals when collecting heredoc markers

Close #3588.

Signed-off-by: Masatake YAMATO <yamato@redhat.com>

Units/parser-perl.r/no-heredoc.d/args.ctags

@@ -0,0 +1,2 @@
+--sort=no
+--kinds-Perl=+{heredoc}

Units/parser-perl.r/no-heredoc.d/expected.tags

@@ -0,0 +1,14 @@
+f0tag	input.pl	/^sub f0tag() {}$/;"	s
+f1tag	input.pl	/^sub f1tag() {}$/;"	s
+f2tag	input.pl	/^sub f2tag() {}$/;"	s
+f3tag	input.pl	/^sub f3tag() {}$/;"	s
+hereodc0tag	input.pl	/^print 'cat <<<heredoct0notag' . <<hereodc0tag;$/;"	h
+f4tag	input.pl	/^sub f4tag() {}$/;"	s
+hereodc1tag	input.pl	/^print "cat <<<heredoct1notag" . <<hereodc1tag;$/;"	h
+f5tag	input.pl	/^sub f5tag() {}$/;"	s
+hereodc2tag	input.pl	/^print `cat <<<heredoct1notag` . <<hereodc2tag;$/;"	h
+f6tag	input.pl	/^sub f6tag() {}$/;"	s
+heredoc3tag	input.pl	/^print "abc" . <<heredoc3tag . 'efg' . << "heredoc4tag" . `ls` . '<<heredoc5tag';$/;"	h
+heredoc4tag	input.pl	/^print "abc" . <<heredoc3tag . 'efg' . << "heredoc4tag" . `ls` . '<<heredoc5tag';$/;"	h
+heredoc5tag	input.pl	/^print "abc" . <<heredoc3tag . 'efg' . << "heredoc4tag" . `ls` . '<<heredoc5tag';$/;"	h
+f7tag	input.pl	/^sub f7tag() {}$/;"	s

Units/parser-perl.r/no-heredoc.d/input.pl

@@ -0,0 +1,43 @@
+# Derrived from #3588 submitted by @petdance
+
+sub f0tag() {}
+
+my $x = '<<NOT_A_HEREDOC0';
+
+sub f1tag() {}
+
+print "<<NOT_A_HEREDOC0\n";
+
+sub f2tag() {}
+
+print `cat <<<BASH_HERE_STRING`;
+
+sub f3tag() {}
+
+print 'cat <<<heredoct0notag' . <<hereodc0tag;
+sub f0notag() {}
+hereodc0tag
+
+sub f4tag() {}
+
+print "cat <<<heredoct1notag" . <<hereodc1tag;
+sub f1notag() {}
+hereodc1tag
+
+sub f5tag() {}
+
+print `cat <<<heredoct1notag` . <<hereodc2tag;
+sub f2notag() {}
+hereodc2tag
+
+sub f6tag() {}
+
+print "abc" . <<heredoc3tag . 'efg' . << "heredoc4tag" . `ls` . '<<heredoc5tag';
+sub f3notag() {}
+heredoc3tag
+sub f4notag() {}
+heredoc4tag
+sub f5notag() {}
+heredoc5tag
+
+sub f7tag() {}

parsers/perl.c

@@ -441,6 +441,87 @@ static unsigned char *readHereDocMarker (unsigned char *line,
 	return cp;
 }
 
+enum stringType {
+	STRING_TYPE_NONE = '\0',
+	STRING_TYPE_SINGLEQ = '\'',
+	STRING_TYPE_DOUBLEQ = '"',
+	STRING_TYPE_BACKQ = '`',
+};
+
+
+static const unsigned char *escapeFromString (const unsigned char *line,
+											  const unsigned char *end,
+											  enum stringType stype)
+{
+	bool in_escape = false;
+	const unsigned char *cp = line;
+
+	switch (stype)
+	{
+	case STRING_TYPE_NONE:
+		return line;
+	case STRING_TYPE_SINGLEQ:
+	case STRING_TYPE_DOUBLEQ:
+	case STRING_TYPE_BACKQ:
+		while ((end && cp < end) || (end == NULL && *cp != '\0'))
+		{
+			if (in_escape)
+			{
+				cp++;
+				in_escape = false;
+			}
+			else if (*cp == '\\')
+			{
+				cp++;
+				in_escape = true;
+			}
+			else if (*cp == (unsigned char)stype)
+			{
+				cp++;
+				return cp;
+			}
+			else
+				cp++;
+		}
+		return NULL;
+	default:
+		AssertNotReached ();
+		return NULL;
+	}
+}
+
+static enum stringType isInString (const unsigned char *line,
+								   const unsigned char *end)
+{
+	const unsigned char *cp = line;
+	enum stringType t = STRING_TYPE_NONE;
+
+	while (cp && cp < end)
+	{
+		switch (*cp)
+		{
+		case '\'':
+		case '\"':
+		case '`':
+			t = *cp;
+			break;
+		default:
+			t = STRING_TYPE_NONE;
+			break;
+		}
+
+		cp++;
+		if (t != STRING_TYPE_NONE)
+		{
+			cp = escapeFromString (cp, end, t);
+			break;
+		}
+	}
+
+	return (cp == NULL)? t: STRING_TYPE_NONE;
+}
+
+
 static const unsigned char *collectHereDocMarker (struct hereDocMarkerManager *mgr,
 												  const unsigned char *line)
 {
@@ -452,6 +533,10 @@ static const unsigned char *collectHereDocMarker (struct hereDocMarkerManager *m
 	if (starter == NULL)
 		return NULL;
 
+	enum stringType stype;
+	if ((stype = isInString(line, starter)) != STRING_TYPE_NONE)
+		return escapeFromString (starter + 2, NULL, stype);
+
 	cp = starter + 2;
 	while (isspace (*cp))
 		cp++;